Take a TicTacToe test?

NdNoviceHlp

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,733
Still looking for testers. If you Call Makeform and place the following code in a module you can play TicTacToe. I'm interested in your results if you have time to play 10 games. I find the XL interactive part of this code the most interesting. In this code, XL checks the playing range every 5 seconds to see if there has been any change and reports back to the user... seems useful when looking for input from a user. Anyways, you have 5 seconds to make your move or you may have to wait <5 seconds for XL to move if your real quick on entry. Also, if you want to cheat, it doesn't count and I hope it doesn't need the friendly task manager to end your game as an infinite loop may result. :twisted: Consider yourself warned and good luck! Dave
Code: 
Option Base 1
Public Uf
Dim ttt(3, 3) As Variant, Tie As Integer
Dim cletter As String, pletter As String

Public Sub Tictactoe()
'Plays tictactoe in range A1:C3
Dim cttt(9) As Variant, tiecnt As Integer
Dim ccnt As Integer, ycnt As Integer
tiecnt = 0
ccnt = 0
ycnt = 0
above:
'clear play area & wait for Uf Tb focus change(s)
Sheets("sheet1").Range("a1:c3").Clear
Application.Wait (Now + TimeValue("0:00:01"))
Tie = 0
tryagain:
pletter = Application.InputBox _
("Use capital letter entry. Enter your choice : X or O")
If pletter = "X" Or pletter = "O" Then
If pletter = "X" Then
cletter = "O"
Else
cletter = "X"
End If
Else
MsgBox "Capital X or O"
GoTo tryagain
End If
Randomize
starter = Int((2 * Rnd) + 1)
If starter = 1 Then
MsgBox "I'll start"
Else
MsgBox "You start"
Tie = Tie + 1
loadarray
yourwin
End If
Do
makemove
If checkwin Then
ccnt = ccnt + 1
MsgBox "I win. The score is: " & ccnt & " wins for me, " & ycnt & _
" wins for you and " & tiecnt & " ties"
Exit Do
Else
Tie = Tie + 1
If Tie = 9 Then
tiecnt = tiecnt + 1
MsgBox "It's a tie. The score is: " & ccnt & " wins for me, " & ycnt & _
" wins for you and " & tiecnt & " ties"
Exit Do
End If
loadarray
If yourwin Then
ycnt = ycnt + 1
MsgBox "You win. The score is: " & ccnt & " wins for me, " & ycnt & _
" wins for you and " & tiecnt & " ties"
Exit Do
End If
End If
Tie = Tie + 1
If Tie = 9 Then
tiecnt = tiecnt + 1
MsgBox "It's a tie. The score is: " & ccnt & " wins for me, " & ycnt & _
" wins for you and " & tiecnt & " ties"
Exit Do
End If
Loop
If MsgBox(prompt:="Do you want to play again?", Buttons:=vbYesNo, Title:="PLAY AGAIN") _
= vbYes Then
GoTo above
End If
'Remove the VBcomponent
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=Uf
End Sub

Function yourwin() As Boolean
'players turn
'Dim WsShell
'Dim intText As Integer
yourwin = False
before:
waittime
If anychange Then
If checkwin Then
yourwin = True
Exit Function
End If
Else
MsgBox "IT'S YOUR TURN! HURRY UP!"
'Set WsShell = CreateObject("WScript.Shell")
'intText = WsShell.Popup("IT'S YOUR TURN!", 2, "HURRY UP!")
'Set WsShell = Nothing
GoTo before
End If
End Function

Function makemove()
'randomly generate computer turn
Dim Xoplace As Integer, Loopcnt As Integer
Randomize
Do
Loopcnt = Loopcnt + 1
Xoplace = Int((9 * Rnd) + 1)
If Tie < 3 Or Tie = 8 Or Loopcnt > 100 Then
If Xoplace = 1 And [sheet1!a1] = vbNullString Then
[sheet1!a1] = cletter
Exit Do
End If
If Xoplace = 2 And [sheet1!a2] = vbNullString Then
[sheet1!a2] = cletter
Exit Do
End If
If Xoplace = 3 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = cletter
Exit Do
End If
If Xoplace = 4 And [sheet1!b1] = vbNullString Then
[sheet1!b1] = cletter
Exit Do
End If
If Xoplace = 5 And [sheet1!b2] = vbNullString Then
[sheet1!b2] = cletter
Exit Do
End If
If Xoplace = 6 And [sheet1!b3] = vbNullString Then
[sheet1!b3] = cletter
Exit Do
End If
If Xoplace = 7 And [sheet1!c1] = vbNullString Then
[sheet1!c1] = cletter
Exit Do
End If
If Xoplace = 8 And [sheet1!c2] = vbNullString Then
[sheet1!c2] = cletter
Exit Do
End If
If Xoplace = 9 And [sheet1!c3] = vbNullString Then
[sheet1!c3] = cletter
Exit Do
End If
Else
If Loopcnt < 50 Then
If UDFWinit(Xoplace, cletter) Then
Exit Do
End If
Else
If UDFWinit(Xoplace, pletter) Then
Exit Do
End If
End If
End If
Loop
End Function

Function checkwin() As Boolean
'check for win
If [sheet1!a1] = "X" And [sheet1!b1] = "X" And [sheet1!c1] = "X" Then
checkwin = True
End If
If [sheet1!a2] = "X" And [sheet1!b2] = "X" And [sheet1!c2] = "X" Then
checkwin = True
End If
If [sheet1!a3] = "X" And [sheet1!b3] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "X" And [sheet1!b2] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a3] = "X" And [sheet1!b2] = "X" And [sheet1!c1] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "X" And [sheet1!a2] = "X" And [sheet1!a3] = "X" Then
checkwin = True
End If
If [sheet1!b1] = "X" And [sheet1!b2] = "X" And [sheet1!b3] = "X" Then
checkwin = True
End If
If [sheet1!c1] = "X" And [sheet1!c2] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!b1] = "O" And [sheet1!c1] = "O" Then
checkwin = True
End If
If [sheet1!a2] = "O" And [sheet1!b2] = "O" And [sheet1!c2] = "O" Then
checkwin = True
End If
If [sheet1!a3] = "O" And [sheet1!b3] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!b2] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
If [sheet1!a3] = "O" And [sheet1!b2] = "O" And [sheet1!c1] = "O" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!a2] = "O" And [sheet1!a3] = "O" Then
checkwin = True
End If
If [sheet1!b1] = "O" And [sheet1!b2] = "O" And [sheet1!b3] = "O" Then
checkwin = True
End If
If [sheet1!c1] = "O" And [sheet1!c2] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
End Function

Function loadarray()
'load array
For cnt1 = 1 To 3
For cnt2 = 1 To 3
ttt(cnt1, cnt2) = Cells(cnt1, cnt2)
Next cnt2
Next cnt1
End Function

Function anychange() As Boolean
'compare A1:C3 to previous stored in array(ttt)
anychange = False
For cnt1 = 1 To 3
For cnt2 = 1 To 3
If ttt(cnt1, cnt2) <> Cells(cnt1, cnt2) Then
If Cells(cnt1, cnt2) <> "X" And Cells(cnt1, cnt2) <> "O" Then
MsgBox "This is X or O's. Try again"
Cells(cnt1, cnt2) = vbNullString
Exit Function
End If
If Cells(cnt1, cnt2) <> pletter Then
MsgBox "You are: " & pletter & " Try again"
Cells(cnt1, cnt2) = vbNullString
Exit Function
End If
anychange = True
End If
Next cnt2
Next cnt1
End Function

Function waittime()
Dim PauseTime, Start
    PauseTime = 5    ' Set duration.
    Start = Timer    ' Set start time.
    Do While Timer < Start + PauseTime
        DoEvents    ' Yield to other processes.
    Loop
End Function
Public Sub Makeform()
'Add temporary Userform
    Set Uf = ThisWorkbook.VBProject.VBComponents.Add(3)
  'add textboxes
    Set Tb1 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox1")
    With Tb1
        .Left = 30
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a1"
    End With
    Set Tb2 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox2")
    With Tb2
        .Left = 30
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a2"
    End With
    Set Tb3 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox3")
    With Tb3
        .Left = 30
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a3"
    End With
Set Tb4 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox4")
    With Tb4
        .Left = 100
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b1"
    End With
Set Tb5 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox5")
    With Tb5
        .Left = 100
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b2"
    End With
Set Tb6 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox6")
    With Tb6
        .Left = 100
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b3"
    End With
Set Tb7 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox7")
    With Tb7
        .Left = 170
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c1"
    End With
Set Tb8 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox8")
    With Tb8
        .Left = 170
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c2"
    End With
Set Tb9 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox9")
    With Tb9
        .Left = 170
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c3"
    End With

With Uf.CodeModule
'cancel userform close with "X"
.insertlines 1, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
.insertlines 2, "If CloseMode = vbformcontrolmenu Then Cancel = True"
.insertlines 3, "End Sub"
.insertlines 4, "Private Sub UserForm_Activate()"
.insertlines 5, "call tictactoe"
.insertlines 6, "end sub"
.insertlines 7, "Private Sub TextBox1_Change()"
.insertlines 8, "Textbox5.SetFocus"
.insertlines 9, "End Sub"
.insertlines 10, "Private Sub TextBox2_Change()"
.insertlines 11, "TextBox5.SetFocus"
.insertlines 12, "End Sub"
.insertlines 13, "Private Sub TextBox3_Change()"
.insertlines 14, "TextBox5.SetFocus"
.insertlines 15, "End Sub"
.insertlines 16, "Private Sub TextBox4_Change()"
.insertlines 17, "TextBox5.SetFocus"
.insertlines 18, "End Sub"
.insertlines 19, "Private Sub TextBox5_Change()"
.insertlines 20, "TextBox6.SetFocus"
.insertlines 21, "End Sub"
.insertlines 22, "Private Sub TextBox6_Change()"
.insertlines 23, "TextBox5.SetFocus"
.insertlines 24, "End Sub"
.insertlines 25, "Private Sub TextBox7_Change()"
.insertlines 26, "TextBox5.SetFocus"
.insertlines 27, "End Sub"
.insertlines 28, "Private Sub TextBox8_Change()"
.insertlines 29, "TextBox5.SetFocus"
.insertlines 30, "End Sub"
.insertlines 31, "Private Sub TextBox9_Change()"
.insertlines 32, "TextBox5.SetFocus"
.insertlines 33, "End Sub"
End With

'Properties for the userform
    With Uf
        .Properties("Caption") = "TicTacToe Enter X or O"
        .Properties("Width") = 250
        .Properties("Height") = 200
         End With

'Include the UF in the Userforms collection
    Set vuf = VBA.UserForms.Add(Uf.Name)
    'Show the Userform
    vuf.Show
 End Sub

Function UDFWinit(Checkspot As Integer, XO As String) As Boolean
'random number(checkspot), playing letter(XO)
'temporarily places playing letter at random location(checkspot)
'call checkwin to see if placement wins or blocks win with boolean result
'place letter(true) or return to previous(false)
UDFWinit = False
If Checkspot = 1 And [sheet1!a1] = vbNullString Then
[sheet1!a1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a1] = cletter
End If
UDFWinit = True
Else
[sheet1!a1] = vbNullString
End If
End If
If Checkspot = 2 And [sheet1!a2] = vbNullString Then
[sheet1!a2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a2] = cletter
End If
UDFWinit = True
Else
[sheet1!a2] = vbNullString
End If
End If
If Checkspot = 3 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a3] = cletter
End If
UDFWinit = True
Else
[sheet1!a3] = vbNullString
End If
End If
If Checkspot = 4 And [sheet1!b1] = vbNullString Then
[sheet1!b1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b1] = cletter
End If
UDFWinit = True
Else
[sheet1!b1] = vbNullString
End If
End If
If Checkspot = 5 And [sheet1!b2] = vbNullString Then
[sheet1!b2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b2] = cletter
End If
UDFWinit = True
Else
[sheet1!b2] = vbNullString
End If
End If
If Checkspot = 6 And [sheet1!b3] = vbNullString Then
[sheet1!b3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b3] = cletter
End If
UDFWinit = True
Else
[sheet1!b3] = vbNullString
End If
End If
If Checkspot = 7 And [sheet1!c1] = vbNullString Then
[sheet1!c1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c1] = cletter
End If
UDFWinit = True
Else
[sheet1!c1] = vbNullString
End If
End If
If Checkspot = 8 And [sheet1!c2] = vbNullString Then
[sheet1!c2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c2] = cletter
End If
UDFWinit = True
Else
[sheet1!c2] = vbNullString
End If
End If
If Checkspot = 9 And [sheet1!c3] = vbNullString Then
[sheet1!c3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c3] = cletter
End If
UDFWinit = True
Else
[sheet1!c3] = vbNullString
End If
End If
End Function
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
Hi Dave

6 wins for me and 5 ties - but that probably says more about me as a gamer than your code!

Some thoughts:

I had to dimension most of the variables - was this deliberate? :-D
I found that having Variable Declaration Required turned on meant that the code kept creating userforms - but pushing Option Explicit to the bottom. This caused an error as you would expect. However, when I removed Variable Declaration it worked fine.
After a couple of games the 5 second warning became VERY annoying!!
The game also appears on the worksheet as well as the userform - was this also deliberate?

Other than that it seems fine - a nice piece of work!

Regards
 
Upvote 0
Thanks Glaswegian for your time and comments. The lack of variable declarations was just poor coding. I wasn't able to re-create the error you describe using option explicit? My gaming skills must be poor as I usually win only a bit more than %50... probably because I hurry to avoid that annoying messagebox warning :-D The game does also appear on the worksheet by design. It's not very pretty but it is functional. Again thanks, and if anyone else would like to trial, please do and post your results. Dave
 
Upvote 0
This will be my last frivolous use of webspace on this project. I've added some strategy and variable declaration. It seems that having the start is now key to victory. As before, place this code in a module and call Makeform. Dave
Code: 
Option Explicit
Option Base 1
Public Uf
Dim ttt(3, 3) As Variant, Tie As Integer
Dim cletter As String, pletter As String

Public Sub Tictactoe()
'Plays tictactoe in range A1:C3
Dim Cttt(9) As Variant, Tiecnt As Integer
Dim Ccnt As Integer, Ycnt As Integer, Starter As Integer
Tiecnt = 0
Ccnt = 0
Ycnt = 0
above:
'clear play area & wait for Uf Tb focus change(s)
Sheets("sheet1").Range("a1:c3").Clear
Application.Wait (Now + TimeValue("0:00:01"))
Tie = 0
tryagain:
pletter = Application.InputBox _
("Use capital letter entry. Enter your choice : X or O")
If pletter = "X" Or pletter = "O" Then
If pletter = "X" Then
cletter = "O"
Else
cletter = "X"
End If
Else
MsgBox "Capital X or O"
GoTo tryagain
End If
Randomize
Starter = Int((2 * Rnd) + 1)
If Starter = 1 Then
MsgBox "I'll start"
Else
MsgBox "You start"
Tie = Tie + 1
loadarray
yourwin
End If
Do
makemove
If checkwin Then
Ccnt = Ccnt + 1
MsgBox "I win. The score is: " & Ccnt & " wins for me, " & Ycnt & _
" wins for you and " & Tiecnt & " ties"
Exit Do
Else
Tie = Tie + 1
If Tie = 9 Then
Tiecnt = Tiecnt + 1
MsgBox "It's a tie. The score is: " & Ccnt & " wins for me, " & Ycnt & _
" wins for you and " & Tiecnt & " ties"
Exit Do
End If
loadarray
If yourwin Then
Ycnt = Ycnt + 1
MsgBox "You win. The score is: " & Ccnt & " wins for me, " & Ycnt & _
" wins for you and " & Tiecnt & " ties"
Exit Do
End If
End If
Tie = Tie + 1
If Tie = 9 Then
Tiecnt = Tiecnt + 1
MsgBox "It's a tie. The score is: " & Ccnt & " wins for me, " & Ycnt & _
" wins for you and " & Tiecnt & " ties"
Exit Do
End If
Loop
If MsgBox(prompt:="Do you want to play again?", Buttons:=vbYesNo, Title:="PLAY AGAIN") _
= vbYes Then
GoTo above
End If
'Remove the VBcomponent
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=Uf
End Sub

Function yourwin() As Boolean
'players turn
'Dim WsShell
'Dim intText As Integer
yourwin = False
before:
waittime
If anychange Then
If checkwin Then
yourwin = True
Exit Function
End If
Else
MsgBox "IT'S YOUR TURN! HURRY UP!"
'Set WsShell = CreateObject("WScript.Shell")
'intText = WsShell.Popup("IT'S YOUR TURN!", 2, "HURRY UP!")
'Set WsShell = Nothing
GoTo before
End If
End Function

Function makemove()
'randomly generate computer turn
Dim xOplace As Integer, Loopcnt As Integer
Randomize
Do
Loopcnt = Loopcnt + 1
xOplace = Int((9 * Rnd) + 1)
If Tie < 3 Then
If Strategy(xOplace) Then
Exit Do
End If
End If
If Tie = 8 Or Loopcnt > 100 Then
If xOplace = 1 And [sheet1!a1] = vbNullString Then
[sheet1!a1] = cletter
Exit Do
End If
If xOplace = 2 And [sheet1!a2] = vbNullString Then
[sheet1!a2] = cletter
Exit Do
End If
If xOplace = 3 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = cletter
Exit Do
End If
If xOplace = 4 And [sheet1!b1] = vbNullString Then
[sheet1!b1] = cletter
Exit Do
End If
If xOplace = 5 And [sheet1!b2] = vbNullString Then
[sheet1!b2] = cletter
Exit Do
End If
If xOplace = 6 And [sheet1!b3] = vbNullString Then
[sheet1!b3] = cletter
Exit Do
End If
If xOplace = 7 And [sheet1!c1] = vbNullString Then
[sheet1!c1] = cletter
Exit Do
End If
If xOplace = 8 And [sheet1!c2] = vbNullString Then
[sheet1!c2] = cletter
Exit Do
End If
If xOplace = 9 And [sheet1!c3] = vbNullString Then
[sheet1!c3] = cletter
Exit Do
End If
Else
If Loopcnt <= 40 Then
If UDFWinit(xOplace, cletter) Then
Exit Do
End If
End If
If Loopcnt > 40 And Loopcnt <= 80 Then
If UDFWinit(xOplace, pletter) Then
Exit Do
End If
End If
If Loopcnt > 80 Then
If Strategy(xOplace) Then
Exit Do
End If
End If
End If
Loop
End Function

Function Strategy(xOplace) As Boolean
'places X/O @ corners or middle
Strategy = False
If xOplace = 1 And [sheet1!a1] = vbNullString Then
[sheet1!a1] = cletter
Strategy = True
End If
If xOplace = 3 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = cletter
Strategy = True
End If
If xOplace = 5 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = cletter
Strategy = True
End If
If xOplace = 7 And [sheet1!c1] = vbNullString Then
[sheet1!c1] = cletter
Strategy = True
End If
If xOplace = 9 And [sheet1!c3] = vbNullString Then
[sheet1!c3] = cletter
Strategy = True
End If
End Function

Function checkwin() As Boolean
'check for win
If [sheet1!a1] = "X" And [sheet1!b1] = "X" And [sheet1!c1] = "X" Then
checkwin = True
End If
If [sheet1!a2] = "X" And [sheet1!b2] = "X" And [sheet1!c2] = "X" Then
checkwin = True
End If
If [sheet1!a3] = "X" And [sheet1!b3] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "X" And [sheet1!b2] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a3] = "X" And [sheet1!b2] = "X" And [sheet1!c1] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "X" And [sheet1!a2] = "X" And [sheet1!a3] = "X" Then
checkwin = True
End If
If [sheet1!b1] = "X" And [sheet1!b2] = "X" And [sheet1!b3] = "X" Then
checkwin = True
End If
If [sheet1!c1] = "X" And [sheet1!c2] = "X" And [sheet1!c3] = "X" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!b1] = "O" And [sheet1!c1] = "O" Then
checkwin = True
End If
If [sheet1!a2] = "O" And [sheet1!b2] = "O" And [sheet1!c2] = "O" Then
checkwin = True
End If
If [sheet1!a3] = "O" And [sheet1!b3] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!b2] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
If [sheet1!a3] = "O" And [sheet1!b2] = "O" And [sheet1!c1] = "O" Then
checkwin = True
End If
If [sheet1!a1] = "O" And [sheet1!a2] = "O" And [sheet1!a3] = "O" Then
checkwin = True
End If
If [sheet1!b1] = "O" And [sheet1!b2] = "O" And [sheet1!b3] = "O" Then
checkwin = True
End If
If [sheet1!c1] = "O" And [sheet1!c2] = "O" And [sheet1!c3] = "O" Then
checkwin = True
End If
End Function

Function loadarray()
'load array
Dim Cnt1 As Integer, Cnt2 As Integer
For Cnt1 = 1 To 3
For Cnt2 = 1 To 3
ttt(Cnt1, Cnt2) = Cells(Cnt1, Cnt2)
Next Cnt2
Next Cnt1
End Function

Function anychange() As Boolean
'compare A1:C3 to previous stored in array(ttt)
Dim Cnt1 As Integer, Cnt2 As Integer
anychange = False
For Cnt1 = 1 To 3
For Cnt2 = 1 To 3
If ttt(Cnt1, Cnt2) <> Cells(Cnt1, Cnt2) Then
If Cells(Cnt1, Cnt2) <> "X" And Cells(Cnt1, Cnt2) <> "O" Then
MsgBox "This is X or O's. Try again"
Cells(Cnt1, Cnt2) = vbNullString
Exit Function
End If
If Cells(Cnt1, Cnt2) <> pletter Then
MsgBox "You are: " & pletter & " Try again"
Cells(Cnt1, Cnt2) = vbNullString
Exit Function
End If
anychange = True
End If
Next Cnt2
Next Cnt1
End Function

Function waittime()
Dim PauseTime, Start
    PauseTime = 5    ' Set duration.
    Start = Timer    ' Set start time.
    Do While Timer < Start + PauseTime
        DoEvents    ' Yield to other processes.
    Loop
End Function

Public Sub Makeform()
'Add temporary Userform
Dim Tb1, Tb2, Tb3, Tb4, Tb5, Tb6, Tb7, Tb8, Tb9, Vuf
    Set Uf = ThisWorkbook.VBProject.VBComponents.Add(3)
  'add textboxes
    Set Tb1 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox1")
    With Tb1
        .Left = 30
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a1"
    End With
    Set Tb2 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox2")
    With Tb2
        .Left = 30
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a2"
    End With
    Set Tb3 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox3")
    With Tb3
        .Left = 30
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "a3"
    End With
Set Tb4 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox4")
    With Tb4
        .Left = 100
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b1"
    End With
Set Tb5 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox5")
    With Tb5
        .Left = 100
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b2"
    End With
Set Tb6 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox6")
    With Tb6
        .Left = 100
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "b3"
    End With
Set Tb7 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox7")
    With Tb7
        .Left = 170
        .Top = 30
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c1"
    End With
Set Tb8 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox8")
    With Tb8
        .Left = 170
        .Top = 70
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c2"
    End With
Set Tb9 = Uf.Designer.Controls.Add("Forms.Textbox.1", "TextBox9")
    With Tb9
        .Left = 170
        .Top = 110
        .Width = 54.25
        .Height = 15.75
        .ControlSource = "c3"
    End With

With Uf.CodeModule
'cancel userform close with "X"
.insertlines 1, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
.insertlines 2, "If CloseMode = vbformcontrolmenu Then Cancel = True"
.insertlines 3, "End Sub"
.insertlines 4, "Private Sub UserForm_Activate()"
.insertlines 5, "call tictactoe"
.insertlines 6, "end sub"
.insertlines 7, "Private Sub TextBox1_Change()"
.insertlines 8, "Textbox5.SetFocus"
.insertlines 9, "End Sub"
.insertlines 10, "Private Sub TextBox2_Change()"
.insertlines 11, "TextBox5.SetFocus"
.insertlines 12, "End Sub"
.insertlines 13, "Private Sub TextBox3_Change()"
.insertlines 14, "TextBox5.SetFocus"
.insertlines 15, "End Sub"
.insertlines 16, "Private Sub TextBox4_Change()"
.insertlines 17, "TextBox5.SetFocus"
.insertlines 18, "End Sub"
.insertlines 19, "Private Sub TextBox5_Change()"
.insertlines 20, "TextBox6.SetFocus"
.insertlines 21, "End Sub"
.insertlines 22, "Private Sub TextBox6_Change()"
.insertlines 23, "TextBox5.SetFocus"
.insertlines 24, "End Sub"
.insertlines 25, "Private Sub TextBox7_Change()"
.insertlines 26, "TextBox5.SetFocus"
.insertlines 27, "End Sub"
.insertlines 28, "Private Sub TextBox8_Change()"
.insertlines 29, "TextBox5.SetFocus"
.insertlines 30, "End Sub"
.insertlines 31, "Private Sub TextBox9_Change()"
.insertlines 32, "TextBox5.SetFocus"
.insertlines 33, "End Sub"
End With

'Properties for the userform
    With Uf
        .Properties("Caption") = "TicTacToe Enter X or O"
        .Properties("Width") = 250
        .Properties("Height") = 200
         End With

'Include the UF in the Userforms collection
    Set Vuf = VBA.UserForms.Add(Uf.Name)
    'Show the Userform
    Vuf.Show
 End Sub

Function UDFWinit(Checkspot As Integer, XO As String) As Boolean
'random number(checkspot), playing letter(XO)
'temporarily places playing letter at random location(checkspot)
'call checkwin to see if placement wins or blocks win with boolean result
'place letter(true) or return to previous(false)
UDFWinit = False
If Checkspot = 1 And [sheet1!a1] = vbNullString Then
[sheet1!a1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a1] = cletter
End If
UDFWinit = True
Else
[sheet1!a1] = vbNullString
End If
End If
If Checkspot = 2 And [sheet1!a2] = vbNullString Then
[sheet1!a2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a2] = cletter
End If
UDFWinit = True
Else
[sheet1!a2] = vbNullString
End If
End If
If Checkspot = 3 And [sheet1!a3] = vbNullString Then
[sheet1!a3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!a3] = cletter
End If
UDFWinit = True
Else
[sheet1!a3] = vbNullString
End If
End If
If Checkspot = 4 And [sheet1!b1] = vbNullString Then
[sheet1!b1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b1] = cletter
End If
UDFWinit = True
Else
[sheet1!b1] = vbNullString
End If
End If
If Checkspot = 5 And [sheet1!b2] = vbNullString Then
[sheet1!b2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b2] = cletter
End If
UDFWinit = True
Else
[sheet1!b2] = vbNullString
End If
End If
If Checkspot = 6 And [sheet1!b3] = vbNullString Then
[sheet1!b3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!b3] = cletter
End If
UDFWinit = True
Else
[sheet1!b3] = vbNullString
End If
End If
If Checkspot = 7 And [sheet1!c1] = vbNullString Then
[sheet1!c1] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c1] = cletter
End If
UDFWinit = True
Else
[sheet1!c1] = vbNullString
End If
End If
If Checkspot = 8 And [sheet1!c2] = vbNullString Then
[sheet1!c2] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c2] = cletter
End If
UDFWinit = True
Else
[sheet1!c2] = vbNullString
End If
End If
If Checkspot = 9 And [sheet1!c3] = vbNullString Then
[sheet1!c3] = XO
If checkwin Then
If XO = pletter Then
[sheet1!c3] = cletter
End If
UDFWinit = True
Else
[sheet1!c3] = vbNullString
End If
End If
End Function
 
Upvote 0
Interesting exercise.

As you can well imagine, I haven't looked at the code in detail nor do I intend to use it for the reasons below.

(1) The game *must* end in a tie. Any other result means someone is playing badly or hasn't figured out the simple strategy behind the game.

(2) Creating a userform, adding controls, and having code add code is a no-no in my book especially in this case where there is absolutely no need for it. Well, it lets you distribute a fully functional program in a text-only form (and that is a clever idea) but other than that...

Additional comment:
I don't know the reason for the 5 second time limit. If it is a technical limit (i.e., you have no other way of checking if something has happened) it is wholely unnecessary. A userform can detect mouse up/down events.

I was thinking of writing an article illustrating how to let the user move objects around in a userform with mouse click-and-drag. This was something I did for a marketing research project. However, the functional code is rather extensive and may not be suitable for an introductory piece on the subject. It might be easier to illustrate those concepts with a event-driven ttt. If nothing else, ttt might serve as a building block for the more serious program.

NdNoviceHlp said:
Still looking for testers. If you Call Makeform and place the following code in a module you can play TicTacToe. I'm interested in your results if you have time to play 10 games. I find the XL interactive part of this code the most interesting. In this code, XL checks the playing range every 5 seconds to see if there has been any change and reports back to the user... seems useful when looking for input from a user. Anyways, you have 5 seconds to make your move or you may have to wait <5 seconds for XL to move if your real quick on entry. Also, if you want to cheat, it doesn't count and I hope it doesn't need the friendly task manager to end your game as an infinite loop may result. :twisted: Consider yourself warned and good luck! Dave
{snip}
Click to expand...
 
Upvote 0
Thanks Tushar. As always, your time and input is very much appreciated. For myself, this was just a fun learning excercise. Making XL "play" in a smart and interactive way was the challenge. I'm sorry to report that the game doesn't always end in a tie so I guess I haven't figured out the simple strategy. If you had trialled the code, you would understand the reason for the 5 second time limit. :) I'm happy that you have found some utility for some portions of this code and perhaps someday I'll be able to view it at your site? Have a nice day! Dave
 
Upvote 0
Hi Dave,

Optimal strategy:

Move 1:
Player 1: grab the center square (creates 4 possible winning lines)
Player 2: grab one of the corners (blocks one line of opponent and creates 2 for self)

Move 2:
Player 1: Grab a corner other than the one opposite the one Player 2 took in Move 1. (blocks one of opponent 2 winning lines and creates a winning threat for player 2)
Player 2: Block player 1 (must; no choice)

Move 3-n: Block the other person; if no block necessary, grab any square, perferably in a line that contains only your square. Nonetheless, it won't matter because it's too late to win.

At certain points of the game, a sub-optimal move may be OK (e.g. move 1 by player 1) as long as all subsequent moves are optimal. You will still have a draw. At other junctures it results in an unstoppable win for the the other person (as long as that person plays correctly).
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top