Writing the Code for the Worksheet Module

The remaining code is entered into the code module for the Worksheet object and controls the creation of a word search puzzle. This part of the program only reads data from the hidden worksheet (Lists) so it does not require any file I/O. The code for the Worksheet object module is listed next.

In the same manner as the Activate() event of the UserForm object, the Click() event of the Refresh button (Name property cmdRefresh) serves to fill the Combo Box and List Box controls with the unique topics and words from the Lists worksheet. To clear the worksheet of data requires triggering the Click() event of the Clear All button (cmdClear). The named ranges on the worksheet make the program more readable by identifying what ranges must be cleared of data. Note that the ClearContents() method of the Range object fails if the range contains merged cells; therefore, the Value property of the ranges defined by the names Output and Topic are initialized to a zero-length string in order to clear their content.

Option Explicit

Private Sub cmdRefresh_Click() Dim topics() As String

'Get unique topics and add to combo box.

GetUniqueTopics topics cmbTopics.List = topics cmbTopics.Value = cmbTopics.List(O) End Sub

Private Sub cmdClear_Click()

'Clear the puzzle board and ActiveX controls.

Range("WordList").ClearContents Range("Puzzle").ClearContents Range("Output").Value = "" Range("Topic").Value = "" cmbTopics.Clear lstWords.Clear End Sub

The Change() event of the Combo Box control and the GetWords() sub procedure fill the List Box control with the words associated with the selected topic. The selected topic serves as a title for the puzzle. After the words are added to the List Box, the user may select one item from the list (MultiSelect property fmMultiSelectSingle). This triggers the Click() event procedure of the List Box control which contains a single statement that outputs a string to the worksheet range named Output telling the user what to do next.

Private Sub cmbTopics_Change()

'Get words associated with topic and add to list box.

GetWords

Range("Topic").Value = cmbTopics.Value 'Add a title to the puzzle. End Sub

Private Sub GetWords()

Dim c As Range, cRange As Range Dim ws As Worksheet Dim lastRow As Integer

'Set object variables. The range should only be 'set to the used portion of column A.

Set ws = Worksheets("Lists") lastRow = ws.UsedRange.Rows.Count

Set cRange = Worksheets("Lists").Range("A2:A" & lastRow)

'Loop through column A in Lists worksheet and find

'all unique topics. Then add word from column B to List box.

lstWords.Clear For Each c In cRange

If c.Value = cmbTopics.Value Then lstWords.Addltem ws.Range("B" & c.Row).Value End If

Next lstWords.Addltem "" End Sub

Private Sub lstWords_Click()

Range("Output").Value = "Select a location in the puzzle grid and " _ & "click on an arrow to specify the words direction."

End Sub

The Click() event procedure of the Command Button controls containing an image of an arrow (I used the Picture property to load the images at Design Time) sends program execution to the PlaceWord() sub procedure. The PlaceWord() sub procedure accepts a string argument that indicates the direction ("N", "NE", "E", "SE", "S", "SW", "W", and "NW") in which to write the word in the puzzle. There are a total of eight Click() event procedures that call the PlaceWord() sub procedure.

Private Sub cmdEast_Click()

PlaceWord ("E") End Sub

Private Sub cmdNE_Click()

PlaceWord ("NE") End Sub

Private Sub cmdNorth_Click()

PlaceWord ("N") End Sub

Private Sub cmdNW_Click()

PlaceWord ("NW") End Sub

Private Sub cmdSE_Click()

PlaceWord ("SE") End Sub

Private Sub cmdSouth_Click()

PlaceWord ("S") End Sub

Private Sub cmdSW_Click()

PlaceWord ("SW") End Sub

Private Sub cmdWest_Click()

PlaceWord ("W") End Sub

The idea of adding a word to a puzzle in one of eight different directions is conceptually pretty simple. The practical solution to the problem is a bit more difficult. You should recognize that in order to copy each letter of the word to a worksheet cell, you must loop through the string value of the word one letter per iteration. Next, while proceeding through each letter in the string variable, you must increment or decrement a row and/or column index (depends on the specified direction) in order to locate the next cell before copying a letter to that cell.

The PlaceWord() sub procedure writes the selected word in the List Box control to the specified cells on the worksheet in its puzzle area. For example, if the user clicks on the Command Button control named cmdSE (bottom right button in the 3 x 3 grid of buttons), then the selected word will be written on a diagonal proceeding down and to the right on the puzzle grid, as shown with the word "BOSTON" in Figure 7.19.

Adding words to a puzzle.

Adding words to a puzzle.

An error handler is required in the PlaceWord() sub procedure to ensure that the user has selected a word from the List Box control before trying to add it to the puzzle. VBA generates an error if you try to access the Listlndex property of the List Box control when no item(s) is selected.

The user's selection is validated with a call to the SelectionValid() function procedure before it is written to the puzzle with a call to the WriteWord() sub procedure. The constants INC, DEC, and NOCHANGE are passed to the WriteWord() sub procedure and specify whether to increment, decrement, or do not change the value of the row and column indices while adding the word to the puzzle one letter at a time. For example, if the word is supposed to go straight left to right (wordDirection = "E"), then the column index of the cell must be incremented by one and the row index of the cell must remain unchanged while the word is added to the puzzle letter by letter.

Private Sub PlaceWord(wordDirection As String) Const INC = 1, DEC = -1, NOCHANGE = 0

On Error GoTo ErrorHandler

If Not SelectionValid(wordDirection) Then

Exit Sub End If

'Write word to puzzle grid.

Select Case wordDirection Case Is = "NW"

WriteWord DEC, DEC Case Is = "N"

WriteWord DEC, NOCHANGE Case Is = "NE"

WriteWord DEC, INC Case Is = "E"

WriteWord NOCHANGE, INC Case "SE"

WriteWord INC, INC Case "S"

WriteWord INC, NOCHANGE Case "SW"

WriteWord INC, DEC Case "W"

WriteWord NOCHANGE, DEC

End Select

WordToList 'Add word to the list below puzzle.

Exit Sub ErrorHandler:

Range("Output").Value = "Please select a word from the list!" End Sub

The SelectionValid() and CountCells() function procedures work together to validate the user's selection on the puzzle grid for adding a word. The selection is validated to ensure that the user has selected only one cell, that this cell is within the puzzle grid, and that the entire length of the word fits in the puzzle grid. The CountCells() function procedure helps with the latter task.

Private Function SelectionValid(wordDirection As String) As Boolean Dim wordLength As Integer

'Test that user selected one cell.

If Selection.Count <> 1 Then SelectionValid = False

Range("Output").Value = "You must select ONE cell in the puzzle grid." Exit Function End If

'Start cell must be in the puzzle range.

If (Selection.Row < 2 Or Selection.Row > 16) Or _

(Selection.Column < 2 Or Selection.Column > 16) Then SelectionValid = False

Range("Output").Value = "Your selection must be in the puzzle grid." Exit Function End If

'The word should fit within puzzle range.

wordLength = Len(lstWords.List(lstWords.ListIndex)) If wordLength > CountCells(wordDirection) Then

Range("Output").Value = "The selection does not fit in the target area." SelectionValid = False Exit Function End If

SelectionValid = True End Function

The CountCell() function procedure first calculates the number of available cells going up, down, left, and right from the user's selection on the puzzle grid. Next, a Select/Case structure chooses the number of available cells from these four possible values based on the word's direction. The function returns the maximum allowed number of cells that can be used to add a word to the puzzle in the desired direction. The SelectionValid() function procedure compares this returned value to the length of the word selected by the user in order to validate that word.

Private Function CountCells(wordDirection As String) As Integer Dim numCellsUp As Integer, numCellsDown As Integer Dim numCellsLeft As Integer, numCellsRight As Integer numCellsUp = Selection.Row - 1 numCellsDown = 17 - Selection.Row numCellsLeft = Selection.Column - 1 numCellsRight = 17 - Selection.Column

'Determine the number of available cells in the puzzle grid 'for given word direction. Ignore placement of other words.

Select Case wordDirection Case Is = "NW"

CountCells = Application.WorksheetFunction.Min( _ numCellsUp, numCellsLeft)

CountCells = numCellsUp Case Is = "NE"

CountCells = Application.WorksheetFunction.Min( _ numCellsUp, numCellsRight)

CountCells = numCellsRight Case "SE"

CountCells = Application.WorksheetFunction.Min( _ numCellsDown, numCellsRight)

Case "S"

CountCells = numCellsDown

Case "SW"

CountCells = Application.WorksheetFunction.Min( _ numCellsDown, numCellsLeft)

Case "W"

CountCells = numCellsLeft End Select End Function

The WriteWord() sub procedure adds the word to the puzzle one letter at a time. The word is first converted to all uppercase letters using the UCase() function before a Do-Loop iterates through the word letter by letter. Each letter is written to the appropriate cell based on the values of the vertical and horizontal arguments. These arguments were passed in from the PlaceWord() sub procedure as the INC, DEC, and NOCHANGE constants. That is, the values of the vertical and horizontal arguments will either be 1, -1, or 0. These values are used to increment, decrement, or leave unchanged the row and column indices passed to the Cells property of the Worksheet object.

Private Sub WriteWord(vertical As Integer, horizontal As Integer) Dim curWord As String, wordLength As Integer Dim I As Integer

Dim cellRow As Integer, cellCol As Integer

'Initialize variables.

curWord = UCase(lstWords.Value) wordLength = Len(curWord) cellRow = Selection.Row cellCol = Selection.Column

'Write the word to the puzzle grid in indicated direction.

Cells(cellRow, cellCol).Value = Mid(curWord, I + 1, 1) I = I + 1

cellRow = cellRow + vertical cellCol = cellCol + horizontal Loop While (I < wordLength) End Sub

After a word has been successfully added to the puzzle, the WordToList() sub procedure adds the word to the next cell in a series of cells below the puzzle grid. These cells are a merged set of five cells across one row. For example, the range B18: F18 is merged into one cell as is G18: K18, L18: P18, B19 : F19, and so on. Because merged cells are accessed using the row and column index of the upper most left cell in the range, the merged cells of interest are those with column index values of 2, 7, and 12. Even though I use a For/Each loop to iterate through the defined range of merged cells, I must qualify the cell in a conditional statement using a column index because the loop still accesses every cell in the merged range and I only want it to access every fifth cell.

Private Sub WordToList() Dim c As Range

'Add the word to the list below the puzzle grid. 'Cells are merged across five columns.

For Each c In Range("WordList")

If c.Value = "" And (c.Column = 2 Or c.Column = 7 Or _ c.Column = 12) Then c.Value = lstWords.Value Exit Sub End If

Next End Sub

The Click() event procedure of the Fill button (cmdFill) fills the empty cells in the puzzle grid with randomly chosen uppercase letters. To generate random uppercase letters, I generate random numbers between 65 and 90 and convert them to their ASCII character using the Chr() function. (The ASCII characters A through Z are represented by decimal values 65 through 90.) A For/Each loop searches the puzzle grid for empty cells and adds a letter to each. Figure 7.20 shows an example of a completed puzzle that is ready for printing.

Private Sub cmdFill_Click() Dim c As Range Dim ranNum As Integer

'Output random uppercase characters to 'empty cells in puzzle grid.

A completed word search puzzle.

A completed word search puzzle.

Randomize

For Each c In Range("Puzzle") ranNum = Int(26 * Rnd + 65) If c.Value = "" Then c.Value = Chr(ranNum)

Next

Range("Output").Value = "" End Sub

Randomize

For Each c In Range("Puzzle") ranNum = Int(26 * Rnd + 65) If c.Value = "" Then c.Value = Chr(ranNum)

Next

Range("Output").Value = "" End Sub

The data update form is shown modally when the user clicks the Update Lists button

(cmdUpdateLists).

Private Sub cmdUpdateLists_Click()

frmWordFind.Show vbModal End Sub

The last procedure listed is the Click() event of the Print button (cmdPrint). This procedure first removes the borders and background color from the area of cells that define the puzzle so they won't show on the printout. Next, the PrintArea property of a PageSetup object is set to the string representing the range that defines the puzzle grid and the list of words below it. I defined the range A1 :Q25 in the Wordfind worksheet to the name "Print_Area". The

PrintOut() method of the Worksheet object prints the defined area. Finally, the original borders and color are added back to the puzzle area of the worksheet. An error handler is included to display any runtime errors generated by trying to print the puzzle (for example, No printer available).

Private Sub cmdPrint_Click() On Error GoTo ErrorHandler

'Format puzzle with no borders or color.

Range("Puzzle").Select

Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Selection.Interior.ColorIndex = xlNone

'Print the puzzle and word list below it.

ActiveSheet.PageSetup.PrintArea = "Print_Area" ActiveSheet.PrintOut Copies:=1

'Reset the borders and color on the puzzle.

Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous Selection.Borders(xlEdgeTop).LineStyle = xlContinuous Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Borders(xlEdgeRight).LineStyle = xlContinuous Selection.Borders(xlInsideVertical).LineStyle = xlContinuous Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous Selection.Interior.ColorIndex = 34 Exit Sub

'Output unforeseen errors with printing.

ErrorHandler:

MsgBox Err.Description, vbCritical, "Error" End End Sub

This concludes the Word Find program. If you know someone who likes word search puzzles, you can now create a few for him or her. Add the features described in the Challenges section at the end of the chapter to more easily create puzzles with this program.

Biorhythm Awareness

Biorhythm Awareness

Who else wants to take advantage of biorhythm awareness to avoid premature death, escape life threatening diseases, eliminate most of your life altering mistakes and banish catastrophic events from your life.

Get My Free Ebook


Post a comment