04-02-2025, 03:21 AM
(04-02-2025, 01:11 AM)SierraKen Wrote: This program makes an 18 x 18 word search grid using words you add in the beginning. You can use up to 24 words with words being up to 15 letters long. All of this is explained in the program. It also has printer support to print your puzzle and also clipboard support if you want to paste it into a graphics program, if you wish to save it or change it.
I've always wanted to make one of these but never could. I came incredibly close to making it all by myself today, had the right math pretty much and arrays, it just wasn't cleaned up enough so ChatGPT helped me a little bit with that.
Thank you to B+ on that code that rotates a picture before it prints it. I used that back when I did my Paint Pixels program so I got it from there. B+ used it on his Calendar Making program.
The program uses a white background with black text so it is much easier on your printer. I've tested this quite a few times and it seems to work fine with the 24 word limit. But if for some reason it hangs up and doesn't do anything, just close the app and start over, maybe using smaller words or less of them. It shouldn't though, I just added a fail-safe counter so if it tries too many times with 1 word, it tells you the word and tells you to start the puzzle over.
Tell me what you think, thanks.
Enjoy!
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
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 " Words cannot be over 15 letters long."
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:"
For w = 1 To num
words:
Print Str$(w) + ". ";
Input 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
Next w
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
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
Nice.
Maybe translate the words when input into Caps (letter$=ucase$(letter$) (for both setup and playing)? (avoids error message).
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/