+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Word Search Maker (/showthread.php?tid=3579)
Word Search Maker - SierraKen - 04-02-2025
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
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
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
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
RE: Word Search Maker - bplus - 04-02-2025
+1 Cool!
RE: Word Search Maker - SierraKen - 04-02-2025
Thanks B+!
RE: Word Search Maker - PhilOfPerth - 04-02-2025
(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).
RE: Word Search Maker - SierraKen - 04-02-2025
(04-02-2025, 03:21 AM)PhilOfPerth Wrote: SierraKenThis 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.Yeah I tried that at first, but then I thought about numbers and symbols, and there's a couple symbols between the lower and upper case, so I would have to work around all of that. I might still do it, we'll see. Thanks!
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).
RE: Word Search Maker - SierraKen - 04-02-2025
Now you can use small letters as well, it will just convert them to large letters automatically. Thanks Phil for the idea! It was easier than I thought. I tested it with all the symbols and numbers too, which just lets you type the word again.
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
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."
Print
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) And Mid$(word$(w), ii, 1) < Chr$(97)) Then
Print " No numbers or symbols, try again.": GoTo words
End If
Next ii
For ii = 1 To Len(word$(w))
If Mid$(word$(w), ii, 1) > Chr$(122) Then
Print " No numbers or symbols, try again.": GoTo words
End If
Next ii
For ii = 1 To Len(word$(w))
If Mid$(word$(w), ii, 1) > Chr$(96) Or Mid$(word$(w), ii, 1) < Chr$(123) Then
word$(w) = UCase$(word$(w))
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
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
RE: Word Search Maker - bplus - 04-02-2025
Ken have you thought about displaying a solution if a person can't find the word?
RE: Word Search Maker - SierraKen - 04-02-2025
Yeah I've thought about it briefly. I might look into it. Thanks.
RE: Word Search Maker - SierraKen - 04-02-2025
Now it will show the answer to a word when you press A, then a number of a word on the list. It will light up the answer in red for 5 seconds, then it will go back to the regular puzzle. Thanks B+ for the idea!
I almost did it completely myself again. I got it down where it lit up just the first letter of the word. But I couldn't figure out the rest so I went to chatgpt again. It was so simple, I almost fell over in my chair lol. It uses SELECT CASE which I really need to practice on. But it works now!
I added a few things chatgpt didn't tell me, like making it inkey$ (and VAL) instead of input and also going back to the main puzzle after 5 seconds, as well as the numbers on the list. I hope you all enjoy it as much as I had making this. Tell me what you think, thanks.
(Code Deleted, please go to next page for the fix, thank you.)
RE: Word Search Maker - bplus - 04-02-2025
My idea was to copy the puzzle before you filled it in with junk, lets see what you and Chat came up with