Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Word Search Maker
#1
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

Reply
#2
+1 Cool!
b = b + ...
Reply
#3
Thanks B+! Big Grin
Reply
#4
(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
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


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.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#5
(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. 

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



Nice.
Maybe translate the words when input into Caps (letter$=ucase$(letter$) (for both setup and playing)? (avoids error message).
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!
Reply
#6
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

Reply
#7
Ken have you thought about displaying a solution if a person can't find the word?
b = b + ...
Reply
#8
Yeah I've thought about it briefly. I might look into it. Thanks. Smile
Reply
#9
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! Smile 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.)
Reply
#10
My idea was to copy the puzzle before you filled it in with junk, lets see what you and Chat came up with Smile
b = b + ...
Reply




Users browsing this thread: 2 Guest(s)