Attribute VB_Name = "modWordSearch"

Option Explicit

Public Type tPOINTAPI
        lX              As Long
        lY              As Long
End Type

Public Type tRECT
        lLeft           As Long
        lTop            As Long
        lRight          As Long
        lBottom         As Long
End Type

Public Type tCoordinates
    nX                  As Integer
    nY                  As Integer
End Type

Public Type tWords
    sWord               As String                   ' Puzzle word.
    nIndex              As Integer                  ' Word's ordinal index in the word collection.
    bytReadDir          As Byte                     ' Word's reading direction.
    sCellIndeces        As String                   ' The indeces of the cells on the word's path.
    bFound              As Boolean
    nHintCount          As Integer
End Type

Public Type tCells
    tPosition           As tCoordinates             ' Coordinates of cell corresponding to the column and row numbers.
    nIndex              As Integer                  ' Cell's ordinal index in the cell collection.
    nLeft               As Integer                  ' Horizontal position of cell on the board.
    nTop                As Integer                  ' Vertical position of cell on the board.
    sLetter             As String                   ' Letter value of the cell.
    sWordIndeces        As String                   ' The indeces of the words by which the letter was used/included.
    nPickCounter        As Integer
End Type

Public Type tWSOptions
    nColCount           As Integer                  ' The number of columns on the board.
    nRowCount           As Integer                  ' The number of rows on the board.
    nWordCount          As Integer                  ' The number of words to be included in the puzzle.
    nMaxLetterCount     As Integer                  ' The maximum number of letters for word selection.
    nMinLetterCount     As Integer                  ' The minimum number of letters for word selection.
End Type

Public Type tTimers
    lSelectionTimer                     As Long
    lMoveBoardOnSelectionTimer          As Long
    lMoveBoardOnWordSelectionTimer      As Long
    lMoveBoardOnPencilSelectionTimer    As Long
    lMoveBoardOnMagnificationTimer      As Long
    lTimeElapsedTimer                   As Long
End Type

'System timer
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

'Graphics manipulations
Public Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

'Clipping mouse pointer inside the puzzle board container area.
Public Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As tPOINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As tPOINTAPI) As Long
Public Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As tPOINTAPI) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As tRECT) As Long

'Sculpting objects
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As tPOINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Putting the target window order position
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long

'Constants for setting the window's display order.
Public Const Flags = 3
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

Public Const RESID_SAVE_PUZZLE      As Integer = 101
Public Const RESID_SAVE_WORDS       As Integer = 102
Public Const RESID_SAVE_CELLS       As Integer = 103
Public Const RESID_LOAD_PUZZLES     As Integer = 104
Public Const RESID_SAVE_GAME        As Integer = 105
Public Const RESID_LOAD_GAMES       As Integer = 106

Public Const CREATED_CELLS_TABLE    As String = "CreatedCells"
Public Const CREATED_WORDS_TABLE    As String = "CreatedWords"
Public Const CREATED_PUZZLES_TABLE  As String = "CreatedPuzzles"
Public Const PUZZLE_NAME_FIELD      As String = "PuzzleName"
Public Const WORD_FIELD             As String = "Word"

Public Const SCROLLBAR_WH           As Integer = 17 ' Width of vertical scrollbar and height of horizontal scroll bar
Public Const CELLSIZE               As Integer = 25 ' Size of cells on the board.
Public Const EMPTY_STRING           As String = ""  ' Zero-length string value.

'Character constants used to separate concatenated strings.
Public Const STR_SEPARATOR          As String = "/"
Public Const PARAM_SEPARATOR        As String = "|"
Public Const VAL_SEPARATOR          As String = "$"
Public Const DET_SEPARATOR          As String = "@"
Public Const TIME_SEPARATOR         As String = ":"
Public Const COORDINATE_SEPARATOR   As String = ","

' Word selection hint constants
Public Const FIRST_HINT             As Byte = 1
Public Const SECOND_HINT            As Byte = 2
Public Const THIRD_HINT             As Byte = 3

'Character constant used to identify a parameter input in a resource string query statement
Public Const PARAM_CHAR             As String = "?"

'Constants for word reading directions
Public Const FORWARD                As Byte = 0
Public Const BACKWARD               As Byte = 1
Public Const UPWARD                 As Byte = 2
Public Const DOWNWARD               As Byte = 3
Public Const SLASH_UPWARD           As Byte = 4
Public Const SLASH_DOWNWARD         As Byte = 5
Public Const BACKSLASH_UPWARD       As Byte = 6
Public Const BACKSLASH_DOWNWARD     As Byte = 7

' Constants for object selection movements
Public Const NO_MOVE                As Integer = -1
Public Const MOVE_UP                As Integer = 0
Public Const MOVE_RIGHT             As Integer = 1
Public Const MOVE_DOWN              As Integer = 2
Public Const MOVE_LEFT              As Integer = 3


'Variables for data manipulations such as storing and retrieving words, saving created puzzle boards, etc.
Public CN                           As New ADODB.Connection
Public RS                           As New ADODB.Recordset
Public ST                           As New ADODB.Stream
Public SQL                          As String

'Puzzle specifications for play sessions.
Public wsPutPlayOptions             As tWSOptions
Public wsPuatPlayCells()            As tCells
Public wsPuatPlayWords()            As tWords

'Puzzle specifications for creating board puzzles.
Public wsPutCreateOptions           As tWSOptions
Public wsPuatCreateCells()          As tCells
Public wsPuatCreateWords()          As tWords

' Miscellaneous public identifiers and object variables
Public wsPubIsLoaded                As Boolean      ' Boolean flag used to indicate whether a game is loaded or not
Public wsPubStop                    As Boolean      ' Boolean flag used to indicate whether the puzzle board creator clickde the Stop button
Public wsPubCancel                  As Boolean      ' Boolean flag used to indicate whether the puzzle board creator clickde the Cancel button
Public wsPunSelCtr                  As Integer      ' Word selection counter
Public wsPusPuzzleName              As String       ' Name of current puzzle board
Public wsPusPassword                As String       ' Password of currently loaded game
Public wsPusGameName                As String       ' Name of currently loaded game

Public tPulpPoint                   As tPOINTAPI
Public tTimer                       As tTimers

Function OpenConnection(Optional ByVal UserID As String = "root", Optional ByVal Pwd As String = "ok", Optional ByVal Host As String = "localhost") As Boolean

On Error GoTo BailOut

Screen.MousePointer = vbHourglass

If CN.State = adStateOpen Then CN.Close

CN.CursorLocation = adUseClient
CN.Open "PROVIDER=MSDASQL;DRIVER={MySQL ODBC 5.1 Driver};DATABASE=WS;SERVER=" & Host & ";UID=" & UserID & ";PASSWORD=" & Pwd & ";OPTION=16427"
Screen.MousePointer = vbDefault
OpenConnection = True
Exit Function

BailOut:

    Screen.MousePointer = vbDefault
    MsgBox Err.Description, vbCritical, "Logon Error"

End Function

Sub TimeElapsedTimer()

Dim ssCtr As String, smCtr As String, shCtr As String
Dim DisplayCtr As String

With frmPlay

    .lsCtr = .lsCtr + 1
    If .lsCtr = 60 Then
        .lsCtr = 0
        .lmCtr = .lmCtr + 1
        If .lmCtr = 60 Then
            .lhCtr = .lhCtr + 1
            .lmCtr = 0
        End If
    End If
    
    ssCtr = String(2 - Len(CStr(.lsCtr)), "0") & CStr(.lsCtr)
    smCtr = String(2 - Len(CStr(.lmCtr)), "0") & CStr(.lmCtr)
    shCtr = String(2 - Len(CStr(.lhCtr)), "0") & CStr(.lhCtr)
    
    DisplayCtr = shCtr & ":" & smCtr & ":" & ssCtr
    .lblTimer = CStr(DisplayCtr)
    DoEvents

End With

End Sub

Sub MagnificationTimer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)

On Error Resume Next

With frmPlay

    .picBoard.Visible = False
    
    If .nMove = MOVE_DOWN Then
        If .picBoard.Top > .picCon.ScaleHeight - .picBoard.Height Then
            .picBoard.Top = .picBoard.Top - CELLSIZE
            .vs.Value = .vs.Value + CELLSIZE
            If .picBoard.Top < .picCon.ScaleHeight - .picBoard.Height Then
                KillTimer 0, tTimer.lMoveBoardOnMagnificationTimer
                .vs.Value = .vs.Max
                .picBoard.Top = .picCon.ScaleHeight - .picBoard.Height
            End If
        End If
    End If
    
    If .nMove = MOVE_UP Then
        If .picBoard.Top < 0 Then
            .picBoard.Top = .picBoard.Top + CELLSIZE
            .vs.Value = .vs.Value - CELLSIZE
            If .picBoard.Top > 0 Then
                KillTimer 0, tTimer.lMoveBoardOnMagnificationTimer
                .vs.Value = .vs.Min
                .picBoard.Top = 0
            End If
        End If
    End If
    
    If .nMove = MOVE_RIGHT Then
        If .picBoard.Left > .picCon.ScaleWidth - .picBoard.Width Then
            .picBoard.Left = .picBoard.Left - CELLSIZE
            .hs.Value = .hs.Value + CELLSIZE
            If .picBoard.Left < .picCon.ScaleWidth - .picBoard.Width Then
                KillTimer 0, tTimer.lMoveBoardOnMagnificationTimer
                .hs.Value = .hs.Max
                .picBoard.Left = .picCon.ScaleWidth - .picBoard.Width
            End If
        End If
    End If
    
    If .nMove = MOVE_LEFT Then
        If .picBoard.Left < 0 Then
            .picBoard.Left = .picBoard.Left + CELLSIZE
            .hs.Value = .hs.Value - CELLSIZE
            If .picBoard.Left > 0 Then
                KillTimer 0, tTimer.lMoveBoardOnMagnificationTimer
                .hs.Value = .hs.Min
                .picBoard.Left = 0
            End If
        End If
    End If
    
    .UpdateMagBuffer
    .UpdateMagImage
    
    .picBoard.Visible = True

End With

End Sub

Sub SelectionTimer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)

With frmPlay

    .nSelectCounter = .nSelectCounter + 1
    .lvwWords.SelectedItem = .lvwWords.ListItems(.nSelectCounter)
    .lvwWords.ListItems(.nSelectCounter).Selected = True
    .nSelIndex = .nSelectCounter
    KillTimer 0, tTimer.lSelectionTimer
    tTimer.lMoveBoardOnSelectionTimer = SetTimer(0, 0, 1, AddressOf MoveBoardOnSelection)
    .lvwWords.SetFocus
    
End With

End Sub

Sub PencilSelectionTimer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)

On Error Resume Next
With frmPlay

    .picBoard.Visible = False
    
    If .nMove = MOVE_DOWN Then
        If .picBoard.Top > .picCon.ScaleHeight - .picBoard.Height Then
            .picBoard.Top = .picBoard.Top - CELLSIZE
            .vs.Value = .vs.Value + CELLSIZE
            If .picBoard.Top < .picCon.ScaleHeight - .picBoard.Height Then
                KillTimer 0, tTimer.lMoveBoardOnPencilSelectionTimer
                .vs.Value = .vs.Max
                .picBoard.Top = .picCon.ScaleHeight - .picBoard.Height
            End If
        End If
    End If
    
    If .nMove = MOVE_UP Then
        If .picBoard.Top < 0 Then
            .picBoard.Top = .picBoard.Top + CELLSIZE
            .vs.Value = .vs.Value - CELLSIZE
            If .picBoard.Top > 0 Then
                KillTimer 0, tTimer.lMoveBoardOnPencilSelectionTimer
                .vs.Value = .vs.Min
                .picBoard.Top = 0
            End If
        End If
    End If
    
    If .nMove = MOVE_RIGHT Then
        If .picBoard.Left > .picCon.ScaleWidth - .picBoard.Width Then
            .picBoard.Left = .picBoard.Left - CELLSIZE
            .hs.Value = .hs.Value + CELLSIZE
            If .picBoard.Left < .picCon.ScaleWidth - .picBoard.Width Then
                KillTimer 0, tTimer.lMoveBoardOnPencilSelectionTimer
                .hs.Value = .hs.Max
                .picBoard.Left = .picCon.ScaleWidth - .picBoard.Width
            End If
        End If
    End If
    
    If .nMove = MOVE_LEFT Then
        If .picBoard.Left < 0 Then
            .picBoard.Left = .picBoard.Left + CELLSIZE
            .hs.Value = .hs.Value - CELLSIZE
            If .picBoard.Left > 0 Then
                KillTimer 0, tTimer.lMoveBoardOnPencilSelectionTimer
                .hs.Value = .hs.Min
                .picBoard.Left = 0
            End If
        End If
    End If
    
    .UpdateMagBuffer
    .UpdateMagImage
    
    .picBoard.Visible = True

End With

End Sub

Sub WordSelectionTimer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long)

On Error Resume Next
Dim nRem As Integer

With frmPlay

    .picBoard.Visible = False
    
    If .nMove = MOVE_DOWN Then
        If .picBoard.Top < .nTargetBoardPosition Then
            nRem = .nTargetBoardPosition - .picBoard.Top
            If nRem >= CELLSIZE Then nRem = CELLSIZE
            .picBoard.Top = .picBoard.Top + nRem
            .vs.Value = .vs.Value - nRem
            If .picBoard.Top >= .nTargetBoardPosition Then
                KillTimer 0, tTimer.lMoveBoardOnWordSelectionTimer
                .vs.Value = Abs(.nTargetBoardPosition)
                .picBoard.Top = .nTargetBoardPosition
                tTimer.lMoveBoardOnSelectionTimer = SetTimer(0, 0, 1, AddressOf MoveBoardOnSelection)
            End If
        End If
    End If
    
    If .nMove = MOVE_UP Then
        If .picBoard.Top > .nTargetBoardPosition Then
            nRem = .picBoard.Top - .nTargetBoardPosition
            If nRem >= CELLSIZE Then nRem = CELLSIZE
            .picBoard.Top = .picBoard.Top - nRem
            .vs.Value = .vs.Value + nRem
            If .picBoard.Top <= .nTargetBoardPosition Then
                KillTimer 0, tTimer.lMoveBoardOnWordSelectionTimer
                .vs.Value = Abs(.nTargetBoardPosition)
                .picBoard.Top = .nTargetBoardPosition
                tTimer.lMoveBoardOnSelectionTimer = SetTimer(0, 0, 1, AddressOf MoveBoardOnSelection)
            End If
        End If
    End If
    
    If .nMove = MOVE_RIGHT Then
        If .picBoard.Left < .nTargetBoardPosition Then
            nRem = .nTargetBoardPosition - .picBoard.Left
            If nRem >= CELLSIZE Then nRem = CELLSIZE
            .picBoard.Left = .picBoard.Left + nRem
            .hs.Value = .hs.Value - nRem
            If .picBoard.Left >= .nTargetBoardPosition Then
                KillTimer 0, tTimer.lMoveBoardOnWordSelectionTimer
                .hs.Value = Abs(.nTargetBoardPosition)
                .picBoard.Left = .nTargetBoardPosition
                tTimer.lMoveBoardOnSelectionTimer = SetTimer(0, 0, 1, AddressOf MoveBoardOnSelection)
            End If
        End If
    End If
    
    If .nMove = MOVE_LEFT Then
        If .picBoard.Left > .nTargetBoardPosition Then
            nRem = .picBoard.Left - .nTargetBoardPosition
            If nRem >= CELLSIZE Then nRem = CELLSIZE
            .picBoard.Left = .picBoard.Left - nRem
            .hs.Value = .hs.Value + nRem
            If .picBoard.Left <= .nTargetBoardPosition Then
                KillTimer 0, tTimer.lMoveBoardOnWordSelectionTimer
                .hs.Value = Abs(.nTargetBoardPosition)
                .picBoard.Left = .nTargetBoardPosition
                tTimer.lMoveBoardOnSelectionTimer = SetTimer(0, 0, 1, AddressOf MoveBoardOnSelection)
            End If
        End If
    End If
    
    .UpdateMagBuffer
    .UpdateMagImage
    
    .picBoard.Visible = True

End With

End Sub

Sub MoveBoardOnSelection()

On Error GoTo errMe

frmPlay.PositionBoard CInt(frmPlay.lvwWords.ListItems(frmPlay.nSelIndex).Tag)
Exit Sub

errMe:

    Open "C:\Err.txt" For Output As #1
    Print #1, Err.Description
    Close (1)
    
End Sub

Sub Main()

OpenConnection
Initialize
frmMain.Show

End Sub

Sub Initialize()

With wsPutPlayOptions
    .nColCount = 15
    .nRowCount = 10
    .nWordCount = 10
    .nMinLetterCount = 4
    .nMaxLetterCount = 10
End With

wsPutCreateOptions = wsPutPlayOptions
wsPusPuzzleName = EMPTY_STRING
wsPubIsLoaded = False

End Sub

Public Sub SetFormIcon(ByRef This As Form)
    This.Icon = LoadResPicture(105, vbResIcon)
End Sub

Function fsResolveResourceString(ByVal siValues As String, _
                                 ByVal niResID As Integer) As String

Dim asValues()      As String
Dim i               As Integer
Dim j               As Integer
Dim sResString      As String

asValues = Split(siValues, PARAM_SEPARATOR)
sResString = LoadResString(niResID)

For i = 0 To UBound(asValues) - 1
    sResString = Replace(sResString, CStr(i) & PARAM_CHAR, asValues(i))
Next

fsResolveResourceString = sResString

End Function

Sub SetWordSearch(ByRef toOptions As tWSOptions, ByRef toWords() As tWords, ByRef toCells() As tCells, Optional ByRef Progress As PictureBox = Nothing)

InitializeCells toOptions, toCells
InitializeWords toOptions, toWords
If Not Progress Is Nothing Then
    SetWords toOptions, toWords, toCells, Progress
Else
    SetWords toOptions, toWords, toCells
End If

End Sub

Sub InitializeCells(ByRef toOptions As tWSOptions, ByRef toCells() As tCells)

Dim nX              As Integer
Dim nY              As Integer
Dim nCellIndex      As Integer

ReDim toCells(toOptions.nRowCount * toOptions.nColCount) As tCells

For nY = 1 To toOptions.nRowCount
    For nX = 1 To toOptions.nColCount
        
        nCellIndex = nCellIndex + 1
        
        With toCells(nCellIndex)
            .tPosition.nX = nX
            .tPosition.nY = nY
            .nIndex = nCellIndex
            .nLeft = (nX - 1) * CELLSIZE
            .nTop = (nY - 1) * CELLSIZE
            .sLetter = EMPTY_STRING
            .sWordIndeces = EMPTY_STRING
            .nPickCounter = 0
        End With
        
    Next
Next

End Sub

Sub InitializeWords(ByRef toOptions As tWSOptions, _
                    ByRef toWords() As tWords)

Dim nWordCtr        As Integer

ReDim toWords(toOptions.nWordCount) As tWords

For nWordCtr = 1 To toOptions.nWordCount
    With toWords(nWordCtr)
        .bytReadDir = 9
        .nIndex = nWordCtr
        .sWord = EMPTY_STRING
        .sCellIndeces = EMPTY_STRING
        .bFound = False
        .nHintCount = 0
    End With
Next

End Sub

Sub SetWords2(ByRef toOptions As tWSOptions, _
             ByRef toWords() As tWords, _
             ByRef toCells() As tCells, _
             Optional ByRef Progress As ProgressBar = Nothing)

Dim nWordCtr        As Integer
Dim nRndWordDir     As Integer
Dim sCurWord        As String
Dim nLenWord        As Integer
Dim nCellIndex      As Integer
Dim sCellIndeces    As String

If Not Progress Is Nothing Then
    Progress.Min = 0
    Progress.Max = toOptions.nWordCount
End If

nWordCtr = 1
Do While nWordCtr <= toOptions.nWordCount
    
    Randomize (Format(Time, "ss"))
    
    'Random word reading direction.
    '0 - >  FORWARD
    '1 - >  BACKWARD
    '2 - >  UPWARD
    '3 - >  DOWNWARD
    '4 - >  SLASH_UPWARD
    '5 - >  SLASH_DOWNWARD
    '6 - >  BACKSLASH_UPWARD
    '7 - >  BACKSLASH_DOWNWARD
    nRndWordDir = CInt(Rnd * 7)
    
    'Random word length
    nLenWord = fnLenWord(nRndWordDir, toOptions)
    
    'Starting cell index
    nCellIndex = fnStartingCellIndex(nRndWordDir, nLenWord, toOptions)
    
    'Accumulated target cell indeces
    sCellIndeces = fsCellIndeces(nRndWordDir, nLenWord, nCellIndex, toOptions)
    
    'Try fetching a word
    If fbFetchWord(sCurWord, sCellIndeces, toCells) Then
        
        SetCellLetter sCurWord, sCellIndeces, nWordCtr, toCells
        
        toWords(nWordCtr).sWord = sCurWord
        toWords(nWordCtr).sCellIndeces = sCellIndeces
        toWords(nWordCtr).nIndex = nWordCtr
        toWords(nWordCtr).bytReadDir = nRndWordDir
        
        If Not Progress Is Nothing Then Progress.Value = nWordCtr
                
        nWordCtr = nWordCtr + 1
    
    End If
    
    If wsPubStop Then
        toOptions.nWordCount = nWordCtr - 1
        ReDim Preserve toWords(nWordCtr - 1) As tWords
        GoTo ExitHere
    End If
    
    If wsPubCancel Then
        GoTo ExitHere
    End If
    
    DoEvents
    
Loop
    
ExitHere:
    
Set RS = CN.Execute("UPDATE WS.All_Words SET Picked=0 WHERE Picked=1")
If Not Progress Is Nothing Then Progress.Value = 0

End Sub

Sub SetWords(ByRef toOptions As tWSOptions, _
             ByRef toWords() As tWords, _
             ByRef toCells() As tCells, _
             Optional ByRef Progress As PictureBox = Nothing)

Dim nWordCtr        As Integer
Dim nRndWordDir     As Integer
Dim sCurWord        As String
Dim nLenWord        As Integer
Dim nCellIndex      As Integer
Dim sCellIndeces    As String
Dim nWidth          As Single

Const PROGRESS_WIDTH As Integer = 336

If Not Progress Is Nothing Then
    Progress.Width = 1
    nWidth = PROGRESS_WIDTH / toOptions.nWordCount
End If

nWordCtr = 1
Do While nWordCtr <= toOptions.nWordCount
    
    Randomize (Format(Time, "ss"))
    
    'Random word reading direction.
    '0 - >  FORWARD
    '1 - >  BACKWARD
    '2 - >  UPWARD
    '3 - >  DOWNWARD
    '4 - >  SLASH_UPWARD
    '5 - >  SLASH_DOWNWARD
    '6 - >  BACKSLASH_UPWARD
    '7 - >  BACKSLASH_DOWNWARD
    nRndWordDir = CInt(Rnd * 7)
    
    'Random word length
    nLenWord = fnLenWord(nRndWordDir, toOptions)
    
    'Starting cell index
    nCellIndex = fnStartingCellIndex(nRndWordDir, nLenWord, toOptions)
    
    'Accumulated target cell indeces
    sCellIndeces = fsCellIndeces(nRndWordDir, nLenWord, nCellIndex, toOptions)
    
    'Try fetching a word
    If fbFetchWord(sCurWord, sCellIndeces, toCells) Then
        
        SetCellLetter sCurWord, sCellIndeces, nWordCtr, toCells
        
        toWords(nWordCtr).sWord = sCurWord
        toWords(nWordCtr).sCellIndeces = sCellIndeces
        toWords(nWordCtr).nIndex = nWordCtr
        toWords(nWordCtr).bytReadDir = nRndWordDir
        
        If Not Progress Is Nothing Then Progress.Width = CSng(nWordCtr) * nWidth
                
        nWordCtr = nWordCtr + 1
    
    End If
    
    If wsPubStop Then
        toOptions.nWordCount = nWordCtr - 1
        ReDim Preserve toWords(nWordCtr - 1) As tWords
        GoTo ExitHere
    End If
    
    If wsPubCancel Then
        GoTo ExitHere
    End If
    
    DoEvents
    
Loop
    
ExitHere:
    
Set RS = CN.Execute("UPDATE WS.All_Words SET Picked=0 WHERE Picked=1")
If Not Progress Is Nothing Then Progress.Width = PROGRESS_WIDTH

End Sub

Sub SetWordsFromTable(ByVal sPuzzleName As String, _
                      ByRef toWords() As tWords)

Dim i               As Integer
Dim sDetails()      As String
Dim sDetVals()      As String

Set RS = CN.Execute("SELECT * FROM WS.CreatedWords WHERE PuzzleName='" & sPuzzleName & "'")
sDetails = Split(RS.Fields("Details"), DET_SEPARATOR)

For i = 0 To UBound(sDetails) - 1
    sDetVals = Split(sDetails(i), VAL_SEPARATOR)
    With toWords(i + 1)
        .sWord = sDetVals(0)
        .nIndex = CInt(sDetVals(1))
        .bytReadDir = CInt(sDetVals(2))
        .sCellIndeces = sDetVals(3)
    End With
Next

End Sub

Sub SetCellsFromTable(ByVal sPuzzleName As String, _
                      ByRef toCells() As tCells)

Dim i               As Integer
Dim sDetails()      As String
Dim sDetVals()      As String

Set RS = CN.Execute("SELECT * FROM WS.CreatedCells WHERE PuzzleName='" & sPuzzleName & "'")
sDetails = Split(RS.Fields("Details"), DET_SEPARATOR)

For i = 0 To UBound(sDetails) - 1
    sDetVals = Split(sDetails(i), VAL_SEPARATOR)
    With toCells(i + 1)
        .tPosition.nX = CInt(sDetVals(0))
        .tPosition.nY = CInt(sDetVals(1))
        .nIndex = CInt(sDetVals(2))
        .nLeft = CInt(sDetVals(3))
        .nTop = CInt(sDetVals(4))
        .sLetter = sDetVals(5)
        .sWordIndeces = sDetVals(6)
    End With
Next

End Sub

Function fnLenWord(ByVal niRndWordDir As Integer, _
                   ByRef toOptions As tWSOptions) As Integer

Dim nMax        As Integer
Dim nMin        As Integer
Dim nMinLC      As Integer
Dim nMaxLC      As Integer
Dim nRC         As Integer
Dim nCC         As Integer

nMinLC = toOptions.nMinLetterCount
nMaxLC = toOptions.nMaxLetterCount
nRC = toOptions.nRowCount
nCC = toOptions.nColCount

Randomize (Format(Time, "ss"))

Select Case niRndWordDir
    Case FORWARD, BACKWARD
        nMax = IIf((nMaxLC > nCC), nCC, nMaxLC)
        nMin = IIf((nMinLC > nCC), nCC, nMinLC)
    Case UPWARD, DOWNWARD
        nMax = IIf((nMaxLC > nRC), nRC, nMaxLC)
        nMin = IIf((nMinLC > nRC), nRC, nMinLC)
    Case Else
        If nRC < nCC Then
            nMax = IIf((nMaxLC > nRC), nRC, nMaxLC)
            nMin = IIf((nMinLC > nRC), nRC, nMinLC)
        ElseIf nCC <= nRC Then
            nMax = IIf((nMaxLC > nCC), nCC, nMaxLC)
            nMin = IIf((nMinLC > nCC), nCC, nMinLC)
        End If
End Select

fnLenWord = CInt(Rnd * (nMax - nMin)) + nMin

End Function

Function fbFetchWord(ByRef soCurWord As String, _
                     ByVal siCellIndeces As String, _
                     ByRef toCells() As tCells) As Boolean

Dim nLenWord            As Integer
Dim asCellIndeces()     As String
Dim i                   As Integer
Dim sChar               As String

asCellIndeces = Split(siCellIndeces, STR_SEPARATOR)
nLenWord = UBound(asCellIndeces)

SQL = "SELECT Word FROM WS.All_Words WHERE LenWord=" & CStr(nLenWord) & " AND"

For i = 0 To nLenWord - 1
    sChar = toCells(CInt(asCellIndeces(i))).sLetter
    If sChar <> EMPTY_STRING Then
        SQL = SQL & " INSTR(Word,'" & sChar & "')=" & CStr(i + 1) & " AND "
    End If
Next

SQL = SQL & " Picked=0 ORDER BY RAND() LIMIT 1"

'Query table
Set RS = CN.Execute(SQL)

If Not RS.EOF And Not RS.BOF Then
    soCurWord = StrConv(RS.Fields("Word"), vbUpperCase)
    Set RS = CN.Execute("UPDATE WS.All_Words SET Picked=1 WHERE Word='" & soCurWord & "'")
    fbFetchWord = True
Else
    fbFetchWord = False
End If

End Function

Sub SetCellLetter(ByVal siWord As String, _
                  ByVal siCellIndeces As String, _
                  ByVal niWordIndex As Integer, _
                  ByRef toCells() As tCells)
                  
Dim nLetterCtr      As Integer
Dim sCellIndeces()  As String

sCellIndeces = Split(siCellIndeces, STR_SEPARATOR)

For nLetterCtr = 1 To Len(siWord)
    With toCells(CInt(sCellIndeces(nLetterCtr - 1)))
        If .sLetter = EMPTY_STRING Then
            .sLetter = Mid(siWord, nLetterCtr, 1)
        End If
        .sWordIndeces = .sWordIndeces & CStr(niWordIndex) & STR_SEPARATOR
    End With
Next

End Sub

Function fnStartingCellIndex(ByVal bytiReadDir As Byte, _
                             ByVal niLenWord As Integer, _
                             ByRef toOptions As tWSOptions) As Integer

Dim nRndX           As Integer
Dim nRndY           As Integer

Randomize (Format(Time, "ss"))
Select Case bytiReadDir
    Case FORWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + 1
        nRndY = CInt(Rnd * (toOptions.nRowCount - 1)) + 1
    Case BACKWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + niLenWord
        nRndY = CInt(Rnd * (toOptions.nRowCount - 1)) + 1
    Case UPWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - 1)) + 1
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + niLenWord
    Case DOWNWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - 1)) + 1
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + 1
    Case SLASH_UPWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + 1
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + niLenWord
    Case SLASH_DOWNWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + niLenWord
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + 1
    Case BACKSLASH_UPWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + niLenWord
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + niLenWord
    Case BACKSLASH_DOWNWARD
        nRndX = CInt(Rnd * (toOptions.nColCount - niLenWord)) + 1
        nRndY = CInt(Rnd * (toOptions.nRowCount - niLenWord)) + 1
End Select

fnStartingCellIndex = ((nRndY - 1) * toOptions.nColCount) + nRndX

End Function

Function fsCellIndeces(ByVal bytiReadDir As Byte, _
                       ByVal niLenWord As Integer, _
                       ByVal niIndex As Integer, _
                       ByRef toOptions As tWSOptions) As String
                               
Dim sCellIndeces    As String
Dim i               As Integer
Dim nNewIndex       As Integer
                               
sCellIndeces = EMPTY_STRING
For i = 0 To niLenWord - 1

    Select Case bytiReadDir
        Case FORWARD:               nNewIndex = niIndex + i
        Case BACKWARD:              nNewIndex = niIndex - i
        Case UPWARD:                nNewIndex = niIndex - (i * toOptions.nColCount)
        Case DOWNWARD:              nNewIndex = niIndex + (i * toOptions.nColCount)
        Case SLASH_UPWARD:          nNewIndex = niIndex - (i * toOptions.nColCount) + i
        Case SLASH_DOWNWARD:        nNewIndex = niIndex + (i * toOptions.nColCount) - i
        Case BACKSLASH_UPWARD:      nNewIndex = niIndex - (i * toOptions.nColCount) - i
        Case BACKSLASH_DOWNWARD:    nNewIndex = niIndex + (i * toOptions.nColCount) + i
    End Select
    
    sCellIndeces = sCellIndeces & CStr(nNewIndex) & STR_SEPARATOR

Next
                               
fsCellIndeces = sCellIndeces
                               
End Function

Sub DrawBoard(ByVal niRow As Integer, _
              ByVal niCol As Integer, _
              ByRef Board As PictureBox, _
              Optional ByRef Buffer As PictureBox = Nothing, _
              Optional ByVal Back As PictureBox = Nothing)
              
Dim nX      As Integer
Dim nY      As Integer

Board.Width = niCol * CELLSIZE
Board.Height = niRow * CELLSIZE

If Not Buffer Is Nothing Then
    Buffer.Width = niCol * CELLSIZE
    Buffer.Height = niRow * CELLSIZE
    SetObjectBackGround Back, Buffer
End If

Board.ForeColor = &H8080FF
Board.FillColor = &H40&
For nY = 1 To niRow
    For nX = 1 To niCol
        Rectangle Board.hdc, (nX - 1) * CELLSIZE, (nY - 1) * CELLSIZE, ((nX - 1) * CELLSIZE) + CELLSIZE, ((nY - 1) * CELLSIZE) + CELLSIZE
    Next
Next
Board.Refresh

End Sub

Sub ResetScrollbars(ByRef Board As PictureBox, _
                    ByVal Container As PictureBox, _
                    ByRef vs As VScrollBar, _
                    ByRef hs As HScrollBar, _
                    ByRef Filler As PictureBox)

Dim bHs         As Boolean
Dim bVs         As Boolean

bHs = (Board.Width > Container.ScaleWidth)
bVs = (Board.Height > Container.ScaleHeight)
Filler.Height = SCROLLBAR_WH
Filler.Width = SCROLLBAR_WH

If bHs And Not bVs Then
    hs.Width = Container.ScaleWidth
    hs.Top = Container.ScaleHeight - SCROLLBAR_WH
    Filler.Visible = False
ElseIf Not bHs And bVs Then
    vs.Height = Container.ScaleHeight
    vs.Left = Container.ScaleWidth - SCROLLBAR_WH
    Filler.Visible = False
ElseIf bHs And bVs Then
    hs.Width = Container.ScaleWidth - SCROLLBAR_WH
    vs.Height = Container.ScaleHeight - SCROLLBAR_WH
    hs.Top = Container.ScaleHeight - SCROLLBAR_WH
    vs.Left = Container.ScaleWidth - SCROLLBAR_WH
    Filler.Top = hs.Top
    Filler.Left = vs.Left
    Filler.Visible = True
End If

hs.Visible = bHs
vs.Visible = bVs

If Board.Width > Container.ScaleWidth Then
    hs.Max = Board.Width - (Container.ScaleWidth - IIf((Filler.Visible = True), SCROLLBAR_WH, 0))
    hs.LargeChange = 3 * CELLSIZE
    hs.SmallChange = CELLSIZE
    hs.Value = 0
    Board.Left = 0
Else
    Board.Left = (Container.ScaleWidth - Board.Width - (IIf((vs.Visible = True), SCROLLBAR_WH, 0))) / 2
End If

If Board.Height > Container.ScaleHeight Then
    vs.Max = Board.Height - (Container.ScaleHeight - (IIf((Filler.Visible = True), SCROLLBAR_WH, 0)))
    vs.LargeChange = 3 * CELLSIZE
    vs.SmallChange = CELLSIZE
    vs.Value = 0
    Board.Top = 0
Else
    Board.Top = (Container.ScaleHeight - Board.Height - (IIf((hs.Visible = True), SCROLLBAR_WH, 0))) / 2
End If

End Sub

Sub PrintCellLetters(ByRef Board As PictureBox, _
                     ByVal Container As PictureBox, _
                     ByRef toOptions As tWSOptions, _
                     ByRef toCells() As tCells, _
                     Optional ByRef Buffer As PictureBox = Nothing)

Dim i           As Integer
Dim nTextW      As Single
Dim nTextH      As Single
Dim nCurX       As Integer
Dim nCurY       As Integer

For i = 1 To toOptions.nColCount * toOptions.nRowCount
    With toCells(i)

        Board.ForeColor = &H8080FF
        If .nPickCounter > 0 Then
            Board.FontBold = True
            Board.FillColor = &H800000
            Rectangle Board.hdc, .nLeft, .nTop, .nLeft + CELLSIZE, .nTop + CELLSIZE
        Else
            Board.ForeColor = &H8080FF
            Board.FontBold = False
            Board.FillStyle = vbFSSolid
            Board.FillColor = &H40&
            Rectangle Board.hdc, .nLeft, .nTop, .nLeft + CELLSIZE, .nTop + CELLSIZE
            If .sLetter = EMPTY_STRING Then .sLetter = StrConv(Chr((CInt(Rnd * 25) + 1) + 96), vbUpperCase)
        End If
        
        nTextW = Board.TextWidth(.sLetter)
        nTextH = Board.TextHeight(.sLetter)
        
        nCurX = (CELLSIZE - nTextW) / 2 + .nLeft
        nCurY = (CELLSIZE - nTextH) / 2 + .nTop
        
        Board.CurrentX = nCurX
        Board.CurrentY = nCurY
        
        If .nPickCounter > 0 Then
            Select Case .nPickCounter
                Case 1: Board.ForeColor = vbYellow
                Case 2: Board.ForeColor = vbCyan
                Case 3: Board.ForeColor = &H80FF80
                Case 4: Board.ForeColor = vbMagenta
                Case 5: Board.ForeColor = &HFFC0FF
                Case 6: Board.ForeColor = &HC0E0FF
                Case 7: Board.ForeColor = &HC0E0FF
                Case 8: Board.ForeColor = vbWhite
            End Select
        Else
            Board.ForeColor = vbWhite
        End If
        
        Board.Print .sLetter
        
   End With
Next

End Sub

Sub SetPuzzleProperties(ByRef toOptions As tWSOptions, _
                        ByVal sOptionValues As String)

Dim sValues()   As String

sValues = Split(sOptionValues, STR_SEPARATOR)

With toOptions
    
    If sValues(0) <> EMPTY_STRING Then .nRowCount = CInt(sValues(0))
    If sValues(1) <> EMPTY_STRING Then .nColCount = CInt(sValues(1))
    If sValues(2) <> EMPTY_STRING Then .nMinLetterCount = CInt(sValues(2))
    If sValues(3) <> EMPTY_STRING Then .nMaxLetterCount = CInt(sValues(3))
    If sValues(4) <> EMPTY_STRING Then .nWordCount = CInt(sValues(4))
    
End With

End Sub

Sub LoadDataIntoList(ByRef lstoControl As ListBox, _
                     ByVal siQuerySpecs As String, _
                     ByVal niResID As Integer)

Dim sQuerySpecs()       As String
Dim sResString          As String
Dim i                   As Integer

sResString = LoadResString(niResID)

sQuerySpecs = Split(siQuerySpecs, STR_SEPARATOR)
For i = 0 To UBound(sQuerySpecs) - 1
    sResString = Replace(sResString, CStr(i) & PARAM_CHAR, sQuerySpecs(i))
Next

Set RS = CN.Execute(sResString)
lstoControl.Clear
If Not RS.EOF And Not RS.BOF Then
    While Not RS.EOF
        lstoControl.AddItem RS.Fields(sQuerySpecs(0))
        RS.MoveNext
    Wend
    lstoControl.ListIndex = 0
End If

End Sub

Function fbSelectionOK(ByVal niIndex1 As Integer, _
                       ByVal niIndex2 As Integer, _
                       ByRef noWordIndex As Integer, _
                       ByRef toWords() As tWords, _
                       ByRef toOptions As tWSOptions) As Boolean

Dim sCellIndex()        As String
Dim i                   As Integer

For i = 1 To toOptions.nWordCount
    If Not toWords(i).bFound Then
        sCellIndex = Split(toWords(i).sCellIndeces, STR_SEPARATOR)
        If ((niIndex1 = CInt(sCellIndex(0))) Or (niIndex2 = CInt(sCellIndex(0)))) And _
           ((niIndex1 = CInt(sCellIndex(UBound(sCellIndex) - 1))) Or (niIndex2 = CInt(sCellIndex(UBound(sCellIndex) - 1)))) Then
           
                fbSelectionOK = True
                noWordIndex = i
                Exit Function
                
        End If
    End If
Next

fbSelectionOK = False
       
End Function

Sub SetObjectBackGround(ByRef Back As PictureBox, _
                  ByRef This As Object)

Dim nW  As Integer
Dim nH  As Integer
Dim nX  As Integer
Dim nY  As Integer
Dim nWU  As Integer
Dim nHU  As Integer

Back = LoadResPicture(102, vbResBitmap)

With This
    nWU = (.ScaleWidth / Back.Width)
    nHU = (.ScaleHeight / Back.Height)
    
    For nY = 0 To nHU
        For nX = 0 To nWU
            BitBlt .hdc, nX * Back.ScaleWidth, nY * Back.ScaleHeight, Back.ScaleWidth, Back.ScaleHeight, Back.hdc, 0, 0, vbSrcCopy
        Next
    Next
    Back.Refresh
    .Refresh
End With

End Sub

Sub SetContainerBackGround(ByRef Container As PictureBox, _
                           ByRef This As Object)

'Container = LoadPicture("")
BitBlt Container.hdc, 0, 0, Container.Width, Container.Height, This.hdc, Container.Left + 1, Container.Top, vbSrcCopy
Container.Refresh

End Sub

Sub SetObjectImage(Optional ByRef oControl As Control = Nothing, _
                   Optional ByVal sCaption As String = EMPTY_STRING, _
                   Optional ByVal nResImageID As Integer = 0, _
                   Optional ByRef picSrc As PictureBox = Nothing, _
                   Optional ByRef picDest As PictureBox = Nothing, _
                   Optional ByRef oBack As Object = Nothing, _
                   Optional ByVal bHint As Boolean = False)

Dim lX      As Long
Dim lY      As Long
Dim cX      As Long
Dim cY      As Long
Dim lColor  As Long

On Error Resume Next

If Not oControl Is Nothing Then
    picDest.Width = oControl.Width
    picDest.Height = oControl.Height
End If

picDest = LoadPicture("")        'Clear picture control
If bHint Then SetContainerBackGround picDest, oBack

BitBlt picDest.hdc, 0, 0, picDest.Width, picDest.Height, oBack.hdc, oControl.Left, oControl.Top, vbSrcCopy

picSrc = LoadPicture("")
picSrc = LoadResPicture(nResImageID, vbResBitmap)

If Not oControl Is Nothing Then
    lX = (picDest.ScaleWidth - picSrc.Width) / 2
    lY = 2
Else
    lX = 0
    lY = 0
End If

For cY = 0 To picSrc.ScaleHeight - 1
    For cX = 0 To picSrc.ScaleWidth - 1
        lColor = GetPixel(picSrc.hdc, cX, cY)
        If lColor <> vbBlue Then
            SetPixel picDest.hdc, lX + cX, lY + cY, lColor
        End If
    Next
Next

If Not sCaption = EMPTY_STRING Then

    picDest.ForeColor = vbWhite
    picDest.FontBold = True
    
    picDest.CurrentX = (picDest.ScaleWidth - picDest.TextWidth(sCaption)) / 2
    picDest.CurrentY = (picDest.ScaleHeight - picDest.TextHeight(sCaption)) - 4
    
    picDest.Print sCaption
    
End If

If Not oControl Is Nothing Then
    oControl.Picture = picDest.Image
    oControl.Refresh
End If

picDest.Refresh

End Sub

Function fsPuzzleExists(ByVal siColumnName As String, _
                        ByVal siColumnValue As String, _
                        ByVal siTableName As String) As Boolean

Set RS = CN.Execute("SELECT " & siColumnName & " FROM WS." & siTableName & " WHERE " & siColumnName & "='" & siColumnValue & "'")
fsPuzzleExists = (Not RS.EOF And Not RS.BOF)

End Function

Sub SetListBGImage(ByVal This As Form, _
                   ByRef picBuffer As PictureBox, _
                   ByRef lvw As ListView)

Dim lY  As Long
Dim lH  As Long

lH = This.ScaleHeight - lvw.Top
picBuffer.Width = This.ScaleWidth / 2
picBuffer.Height = lH * 15

picBuffer.Picture = LoadPicture("")

For lY = 1 To 15
    BitBlt picBuffer.hdc, 0, (lY - 1) * lH, picBuffer.Width, lH, This.hdc, lvw.Left, lvw.Top, vbSrcCopy
Next

picBuffer.Refresh
lvw.Picture = picBuffer.Image
lvw.ColumnHeaders(1).Width = lvw.Width - SCROLLBAR_WH

End Sub

