?
Solved

Crossword puzzle creation tool in vb

Posted on 2003-03-26
7
Medium Priority
?
784 Views
Last Modified: 2008-03-06
I have been trying to implement a crossword puzzle creation tool using vb.Having come up with a grid on the picture box how can I write a code that will detect the event of clicking onto a specific number of cell on the picture box
0
Comment
Question by:nw_khaemba
7 Comments
 
LVL 1

Expert Comment

by:robertlees
ID: 8216125
The MouseUp event of the picture box will give you the X and Y position that was clicked. You can then work out which square that is by dividing these numbers by the number of squares across and down.

But do you really need to do it with a PictureBox ? Why not create an array of labels or textboxes. That way, each square is an individual entity. You can make the BackColor black or white as required. If you use textboxes, the user can type a letter directly into that square - you would have to ensure that if there is already a letter there it would be replaced by the new letter.

Let me know if you need more help.
0
 
LVL 3

Expert Comment

by:n_narayanan
ID: 8217768
Hi

Just go here

http://www.a1vbcode.com

and in the search box (Located on top right corner) enter crossword and click search.

You will find a code.

Enjoy

Cheers

Narayanan
0
 
LVL 3

Expert Comment

by:VBtom
ID: 8218719
Hi.

I once tried it like you, with a picturebox, and it is possible. But you'll need a lot of code then and the only advantages are that you can easily print it and that you can save it as a BMP file.
Using a control array of textboxes, as robertlees already suggested, produces much shorter and much easier code.

Try this simple but functional example and after, tell me if you're still convinced using a picturebox::
*create a form with a checkbox (for choosing typing direction) and a small square textbox (the upper left cell of the crossword).
For the textbox, set Alignment to center, Appearance to flat, and Index to 0.
*paste this code:
Dim Rows As Integer
Dim Cols As Integer

Private Sub MoveRight(Index As Integer)
If Index < Rows * Cols - 1 Then
    Text1(Index + 1).SetFocus
Else
    Beep
End If
End Sub

Private Sub MoveLeft(Index As Integer)
If Index > 0 Then
    Text1(Index - 1).SetFocus
Else
    Beep
End If
End Sub

Private Sub MoveDown(Index As Integer)
If Index + Cols < Rows * Cols Then
    Text1(Index + Cols).SetFocus
Else
    If Index = Rows * Cols - 1 Then
        Beep
    Else
        Text1(Index + Cols - Rows * Cols + 1).SetFocus
    End If
End If
End Sub

Private Sub MoveUp(Index As Integer)
If Index - Cols >= 0 Then
    Text1(Index - Cols).SetFocus
Else
    If Index = 0 Then
        Beep
    Else
        Text1(Index - Cols + Rows * Cols - 1).SetFocus
    End If
End If
End Sub

Private Sub Form_Load()
Dim i As Integer
Rows = 20
Cols = 20
Me.ScaleMode = vbPixels
Check1.Caption = "Move down after typing"
Text1(0).MaxLength = 1
For i = 1 To Rows * Cols - 1
    Load Text1(i)
    Text1(i).Left = Text1(0).Left + (i Mod Cols) * (Text1(0).Width - 1)
    Text1(i).Top = Text1(0).Top + (i \ Cols) * (Text1(0).Height - 1)
    Text1(i).Visible = True
Next i
End Sub

Private Sub Text1_Change(Index As Integer)
'Move right or down after typing a character:
If Len(Text1(Index)) = 1 Then
    If Check1 = 0 Then
        MoveRight Index
    Else
        MoveDown Index
    End If
End If

'Use space to create black cell:
If Text1(Index) = " " Then
    Text1(Index).BackColor = vbBlack
Else
    Text1(Index).BackColor = vbWhite
End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
'auto-select
Text1(Index).SelStart = 0: Text1(Index).SelLength = 1
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
'"UCase" every character
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub Text1_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
'Make arrow keys work:
Select Case KeyCode
    Case vbKeyLeft: MoveLeft Index
    Case vbKeyRight: MoveRight Index
    Case vbKeyUp: MoveUp Index
    Case vbKeyDown: MoveDown Index
End Select
End Sub

If you need help on how to print the crossword or how to save it, just ask here.
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 

Author Comment

by:nw_khaemba
ID: 8223902
VBtom I think thats an excellent answer for extra points what code can set the dark area and prevent the cursor from venturing there instead of doing it at run time say I give indicate the cells to be darkened and it does it
0
 
LVL 3

Accepted Solution

by:
VBtom earned 2000 total points
ID: 8239854
Hi nw_khaemba.

Thank you for liking my example. Btw, it has one little cosmetic bug: the arrow-keys should respond to _KeyDown instead of _KeyUp.

I guess you mentioned that when designing a crossword (the example I posted) you can use a space to create blacks.
Why not keep on doing so in play-mode: a cell containing a space = black.
Then when a game starts and the blacks (spaces) have been set, you could disable all cells containing spaces (see procedure DiasbleBlacks).

Also declare a variable PlayMode in the (general) that should be made True when a game starts, and false when you want to create a new crossword.
Dim PlayMode As Boolean
This is because the player may not be able to create blacks pressing space. So when in playmode, let's neutralize space in _KeyPress, and use it for clearing instead
(when not in playmode, spaces are accepted), see Text1_Keypress below.

Also the arrow movement procedures should be refined for skipping blacks.

With this example, you can either design or play a crossword.
Make a form with:
*A checkbox called chkVertical
*A textbox (Text1) with appearance set to flat, borderstyle none, index 0, no text
*A textbox (Text2) with multiline set to true, this is for typing the descriptions of what should be filled in.
*Create the following menu-items: mnuPlay (= open and play a game), mnuDone (= to press when user finishes agame), mnuNew (to create a new crossword), mnuSave (to save the created crossword), mnuEdit (to open and edit a crossword).
For selecting files, I used simple inputboxes in the example. Off course it's better to use commondialog.
---
Option Explicit

Dim Rows As Integer
Dim Cols As Integer

Dim Playmode As Boolean
Dim Solution As String

Private Sub Clear()
Dim i As Integer
For i = 0 To Text1.UBound
       Text1(i) = ""
Next i
End Sub

Private Sub DrawGrid(ByVal NewRows As Integer, ByVal NewCols As Integer)
Dim i As Integer
Me.MousePointer = vbHourglass
For i = 0 To Text1.UBound
    Text1(i).Visible = False
Next i
Clear
Rows = NewRows
Cols = NewCols
'Adjust number of cells:
For i = Text1.UBound To (Rows * Cols) Step -1
    Unload Text1(i)
Next i
For i = (Text1.UBound + 1) To (Rows * Cols - 1)
   Load Text1(i)
   Text1(i).ToolTipText = "Horizontal:" & (i \ Cols) + 1 & " - Vertical:" & (i Mod Cols) + 1
Next i
'Position and show cells:
Text1(0).Visible = True
For i = 1 To Rows * Cols - 1
     Text1(i).Left = Text1(0).Left + (i Mod Cols) * (Text1(0).Width - 1)
     Text1(i).Top = Text1(0).Top + (i \ Cols) * (Text1(0).Height - 1)
     Text1(i).Visible = True
Next i
Me.MousePointer = vbDefault
End Sub

Private Sub DisableBlacks()
Dim i As Integer
For i = 0 To Text1.UBound
    With Text1(i)
     If .Text = " " Then
        .Enabled = False: .TabStop = False
     End If
    End With
Next i
End Sub

Private Sub EnableAllCells()
Dim i As Integer
For i = 0 To Text1.UBound
    With Text1(i)
        .Enabled = True: .TabStop = True
    End With
Next i
End Sub

Private Function GetBlacks(strCrossword As String) As String
Dim blanked As String, i As Integer
blanked = String(Rows * Cols, Chr$(0))
For i = 1 To Len(strCrossword)
    If Mid$(strCrossword, i, 1) = " " Then
        Mid$(blanked, i, 1) = " "
    End If
Next i
GetBlacks = blanked
End Function

Private Function GetCrossWord() As String
Dim strCrossword As String
Dim i As Integer
For i = 0 To Text1.UBound
    If Text1(i) = "" Then
        strCrossword = strCrossword & Chr$(0)
    Else
        strCrossword = strCrossword & Text1(i)
    End If
Next i
GetCrossWord = strCrossword
End Function

Private Sub SetCrossWord(strCrossword As String)
Dim i As Integer
If Len(strCrossword) <> Text1.UBound + 1 Then
    MsgBox "The grid has an incorrect size!" & vbCrLf & _
           "The crossword cannot be loaded", vbCritical
    Exit Sub
End If
   
For i = 0 To Text1.UBound
'    If i = Len(strCrossword) Then Exit For
    Text1(i) = Mid$(strCrossword, i + 1, 1)
Next i
'For i = Len(strCrossword) To Text1.UBound
'    Text1(i) = ""
'Next i
End Sub

Private Sub SetBlacks(strCrossword As String)
SetCrossWord GetBlacks(strCrossword)
End Sub

Private Sub MoveRight(Index As Integer)
Dim NextIndex As Integer
If Index < Text1.UBound Then
    NextIndex = Index + 1
    Do While Text1(NextIndex).Enabled = False
        If NextIndex = Text1.UBound Then 'abort if last cell
            If Text1(NextIndex).Enabled Then Exit Do Else Exit Sub
        End If
        NextIndex = NextIndex + 1
    Loop
    Text1(NextIndex).SetFocus
End If
End Sub

Private Sub MoveLeft(Index As Integer)
Dim NextIndex As Integer
If Index > 0 Then
    NextIndex = Index - 1
    Do While Text1(NextIndex).Enabled = False
        If NextIndex = 0 Then 'abort if first cell
            If Text1(0).Enabled Then Exit Do Else Exit Sub
        End If
        NextIndex = NextIndex - 1
    Loop
    Text1(NextIndex).SetFocus
End If
End Sub

Private Sub MoveDown(Index As Integer)
Dim NextIndex As Integer
If Index \ Cols < Rows - 1 Then 'if cell down is not in last row
    NextIndex = Index + Cols
    Do While Text1(NextIndex).Enabled = False 'skip disabled black cells
        If NextIndex \ Cols = Rows - 1 Then 'abort if cell down is in last row
            If Text1(NextIndex).Enabled Then Exit Do Else Exit Sub
        End If
        NextIndex = NextIndex + Cols '1 row down
    Loop
    Text1(NextIndex).SetFocus
End If
End Sub

Private Sub MoveUp(Index As Integer)
Dim NextIndex As Integer
If Index >= Cols Then 'if cell up is not in first row
    NextIndex = Index - Cols
    Do While Text1(NextIndex).Enabled = False 'skip disabled black cells
        If NextIndex < Cols Then 'abort if cell up in first row
            If Text1(NextIndex).Enabled Then Exit Do Else Exit Sub
        End If
        NextIndex = NextIndex - Cols '1 row up
    Loop
    Text1(NextIndex).SetFocus
End If
End Sub

Private Sub OpenCrossword(FName As String, Optional EditMode As Boolean = False)
Dim i As Integer
Dim NewRows As Integer, NewCols As Integer
Dim strLine As String
On Error GoTo InvalidFile
Open FName For Input As #1
Input #1, NewCols, NewRows
Line Input #1, Solution
Text2 = ""
Do While Not EOF(1)
    Line Input #1, strLine
    Text2 = Text2 & IIf(Text2 <> "", vbCrLf, "") & strLine
Loop
Close #1
On Error GoTo 0
DrawGrid NewCols, NewRows
If Playmode Then
    SetBlacks Solution
    DisableBlacks
    Text2.Locked = True
Else
    SetCrossWord Solution
    EnableAllCells
    Text2.Locked = False
End If
Exit Sub
InvalidFile:
    Close #1
    MsgBox FName & " is no valid crossword file, or does not exist!", vbCritical
    Solution = ""
End Sub

Private Sub Form_Load()
Dim i As Integer
Me.ScaleMode = vbPixels
chkVertical.Caption = "Type vertical"
Text1(0).MaxLength = 1
DrawGrid 20, 20
End Sub

Private Sub mnuDone_Click()
Dim i As Integer
If GetCrossWord = Solution Then
    MsgBox "Congratulations! Everything's correct!", vbExclamation
Else
    If MsgBox("Try Again! Do you wanna clear the mistakes?", vbQuestion + vbYesNo) = vbYes Then
        For i = 1 To Len(Solution)
            If Text1(i - 1) <> Mid$(Solution, i, 1) Then
                Text1(i - 1) = ""
            End If
        Next i
    End If
End If
End Sub

Private Sub mnuEdit_Click()
Dim FName As String
FName = InputBox("Enter filename to open:")
If FName = "" Then Exit Sub
Playmode = False
OpenCrossword FName
End Sub

Private Sub mnuNew_Click()
Dim NewRows As Integer, NewCols As Integer
NewRows = Val(InputBox("Enter number of rows (horizontal):", , 20))
If NewRows = 0 Then Exit Sub
NewCols = Val(InputBox("Enter number of columns (vertical):", , 20))
If NewCols = 0 Then Exit Sub
DrawGrid NewRows, NewCols
EnableAllCells
Playmode = False
Text2.Locked = False
End Sub

Private Sub mnuPlay_Click()
Dim FName As String
FName = InputBox("Enter filename to open:")
If FName = "" Then Exit Sub
Playmode = True
OpenCrossword FName
End Sub

Private Sub mnuSave_Click()
Dim FName As String, i As Integer
FName = InputBox("Enter filename to save solved crossword:")
If FName = "" Then Exit Sub
Open FName For Output As #1
Write #1, Cols, Rows
Print #1, GetCrossWord
Print #1, Text2.Text
Close #1
End Sub

Private Sub Text1_Change(Index As Integer)
'Move right or down after typing a character:
If Len(Text1(Index)) = 1 Then
    If chkVertical = 0 Then
        MoveRight Index
    Else
        MoveDown Index
    End If
End If
'Use space to create black when designing a crossword
'(when in Play mode, space is neutralized in Text1_KeyPress):
If Text1(Index) = " " Then
    Text1(Index).BackColor = vbBlack
Else
    Text1(Index).BackColor = vbWhite
End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
Text1(Index).SelStart = 0: Text1(Index).SelLength = 1
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
'"UCase" every character
KeyAscii = Asc(UCase(Chr(KeyAscii)))
'when in play mode, use space for clearing
If Playmode And KeyAscii = Asc(" ") Then
    KeyAscii = 0 'neutralize to avoid blackening
    If Text1(Index) <> " " Then Text1(Index) = ""
    If chkVertical = 0 Then
        MoveRight Index
    Else
        MoveDown Index
    End If
End If
End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case vbKeyLeft: MoveLeft Index
    Case vbKeyRight: MoveRight Index
    Case vbKeyUp: MoveUp Index
    Case vbKeyDown: MoveDown Index
End Select
End Sub
---
Have fun!
0
 

Author Comment

by:nw_khaemba
ID: 8245199
Vb tom thank you very much and may God bless you. This is a sure thing and I don't know what to say
0
 
LVL 3

Expert Comment

by:VBtom
ID: 8248697
Thanks.
This was funstuff, I liked it.
Glad I could help you.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Suggested Courses

621 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question