04-19-2025, 07:55 PM
I changed it so that the number of words is automatic - you do not have to tell it in advance. Once you press ENTER with a null word it assumes you are done and creates the puzzle. Also all words are capitalized.
Code: (Select All)
'Word Search Maker by SierraKen
'April 1, 2025
'With some help by ChatGPT. I was very close by myself, all of the math and arrays are from me, just needed it cleaned up a bit.
'Thank you to B+ for the graphics rotation code to print on printer.
Dim word$(24), grid$(18, 18)
Screen _NewImage(800, 600, 32)
_Title "Word Search Maker - P to Print on Printer C to Clipboard Space Bar For Another One Esc to Quit"
begin:
t = 0: num = 0: w = 0
Cls
Paint (1, 1), _RGB32(255, 255, 255)
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Print " Word Search Maker"
Print " by SierraKen"
Print: Print: Print
Print " P to Print on Printer."
Print " C to Copy to Clipboard to use with another graphics program."
Print " Space Bar for another one."
Print " Esc to Quit."
Print
Print " Words cannot be over 15 letters long."
Print
'Input " How many words (1-24): ", num
'If num > 24 Or num < 1 Or num <> Int(num) Then GoTo begin
'Cls
Paint (1, 1), _RGB32(255, 255, 255)
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
Print " Type one word at a time here for your puzzle. Only large letters are used:"
Print
GetNextWord:
w = w + 1
words:
Print Str$(w) + ". ";
Input word$(w)
word$(w) = UCase$(_Trim$(word$(w)))
If Len(word$(w)) > 15 Then Print " Words cannot be over 15 letters long.": Print: GoTo words
temp$ = ""
For ii = 1 To Len(word$(w))
If Mid$(word$(w), ii, 1) <> " " Then temp$ = temp$ + Mid$(word$(w), ii, 1)
Next ii
If temp$ <> "" Then word$(w) = temp$ ' Only assign if temp$ changed
For ii = 1 To Len(word$(w))
If Mid$(word$(w), ii, 1) < Chr$(65) Or Mid$(word$(w), ii, 1) > Chr$(90) Then
Print " Only large letters used.": GoTo words
End If
Next ii
If word$(w) = "" Then
If w = 1 Then System
num = w
GoTo DoneInput
End If
If w = 24 GoTo DoneInput
GoTo GetNextWord
DoneInput:
Cls
Paint (1, 1), _RGB32(255, 255, 255)
Color _RGB32(0, 0, 0), _RGB32(255, 255, 255)
' Initialize grid
For y = 1 To 18
For x = 1 To 18
grid$(y, x) = ""
Next x
Next y
Randomize Timer
For w = 1 To num
placement:
t = t + 1
If t > 2000 Then
Print word$(w) + " unable to work with this puzzle, press Enter to start over."
Input ab$
t = 0
GoTo begin
End If
dir = Int(Rnd * 8) + 1
x = Int(Rnd * 18) + 1: y = Int(Rnd * 18) + 1
' Ensure the word fits in the selected direction
If dir = 1 And x + Len(word$(w)) > 18 Then GoTo placement ' Right
If dir = 2 And x - Len(word$(w)) < 1 Then GoTo placement ' Left
If dir = 3 And y + Len(word$(w)) > 18 Then GoTo placement ' Down
If dir = 4 And y - Len(word$(w)) < 1 Then GoTo placement ' Up
If dir = 5 And (x + Len(word$(w)) > 18 Or y + Len(word$(w)) > 18) Then GoTo placement ' Right-Down
If dir = 6 And (x - Len(word$(w)) < 1 Or y + Len(word$(w)) > 18) Then GoTo placement ' Left-Down
If dir = 7 And (x - Len(word$(w)) < 1 Or y - Len(word$(w)) < 1) Then GoTo placement ' Left-Up
If dir = 8 And (x + Len(word$(w)) > 18 Or y - Len(word$(w)) < 1) Then GoTo placement ' Right-Up
' Check for conflicts
For l = 1 To Len(word$(w))
cx = x: cy = y
If dir = 1 Then cx = x + l ' Right
If dir = 2 Then cx = x - l ' Left
If dir = 3 Then cy = y + l ' Down
If dir = 4 Then cy = y - l ' Up
If dir = 5 Then cx = x + l: cy = y + l ' Right-Down
If dir = 6 Then cx = x - l: cy = y + l ' Left-Down
If dir = 7 Then cx = x - l: cy = y - l ' Left-Up
If dir = 8 Then cx = x + l: cy = y - l ' Right-Up
If grid$(cy, cx) <> "" And grid$(cy, cx) <> Mid$(word$(w), l, 1) Then GoTo placement
Next l
' Place word
For l = 1 To Len(word$(w))
cx = x: cy = y
If dir = 1 Then cx = x + l ' Right
If dir = 2 Then cx = x - l ' Left
If dir = 3 Then cy = y + l ' Down
If dir = 4 Then cy = y - l ' Up
If dir = 5 Then cx = x + l: cy = y + l ' Right-Down
If dir = 6 Then cx = x - l: cy = y + l ' Left-Down
If dir = 7 Then cx = x - l: cy = y - l ' Left-Up
If dir = 8 Then cx = x + l: cy = y - l ' Right-Up
grid$(cy, cx) = Mid$(word$(w), l, 1)
Next l
t = 0
Next w
' Fill empty spaces with random letters
For y = 1 To 18
For x = 1 To 18
If grid$(y, x) = "" Then grid$(y, x) = Chr$(Int(Rnd * 26) + 65)
Next x
Next y
' Display grid with spaces between letters
For y = 1 To 18
For x = 1 To 18
Locate y + 5, (x * 2) + 30: Print grid$(y, x); " ";
Next x
Print
Next y
listx = 15: listy = 25
For l = 1 To num
listy = listy + 1
If listy / 8 = Int(listy / 8) Then
listy = 26: listx = listx + 20
End If
Locate listy, listx: Print word$(l)
Next l
Do
a$ = InKey$
If a$ = "c" Or a$ = "C" Then
landscape2& = _CopyImage(0)
_ClipboardImage = landscape2&
For sz = 0 To 20
Line (sz, sz)-(800 - sz, 600 - sz), _RGB32(255, 0, 0), B
Next sz
_Delay 4
For sz = 0 To 20
Line (sz, sz)-(800 - sz, 600 - sz), _RGB32(255, 255, 255), B
Next sz
_FreeImage landscape2&
End If
If a$ = "p" Or a$ = "P" Then
'printer prep (code from bplus Free Calendar Program)
YMAX = _Height: XMAX = _Width
landscape& = _NewImage(YMAX, XMAX, 32)
_MapTriangle (XMAX, 0)-(0, 0)-(0, YMAX), 0 To(0, 0)-(0, XMAX)-(YMAX, XMAX), landscape&
_MapTriangle (XMAX, 0)-(XMAX, YMAX)-(0, YMAX), 0 To(0, 0)-(YMAX, 0)-(YMAX, XMAX), landscape&
_PrintImage landscape&
_Delay 2
_FreeImage landscape&
End If
If a$ = " " Then GoTo begin
If a$ = Chr$(27) Then End
Loop