Dave
06-12-2005, 11:01 PM
I've been thinking about how to create a sort of XL smarts that would be able to tie & beat a player +50% in a game of TicTacToe. I'm sure from a philisophical point of view this may have crushing implications...a quasi intelligence sort of blows away I think, therefore I am. :cloud9: It seems to me I need to create a few UDF's in order for this to happen... so if it's raining and you enjoy brain dead games and/or quasi productive undertakings, I encourage you to join in and make the best UDF to outsmart yourself. The following code placed in a module plays the game when you call Makeform... and yes I know it ain't pretty. It currently randomly generates the computer's play. My plan which I'am very flexible with is as follows:
'on computer move:
'randomly select number and place if it meets conditions:
'starting or tieing move(Tie:1 or 9) ie. exit
'UDFWinit: check for 2 computer X/O's together or spaced apart
'UDFBlockit: check for 2 player O/X's together or spaced apart
'UDFStrategy: place computer X/O beside another X/O
'else: randomly select another number
'loop until X placed
I'm also quite sure had I hit the search button enough times I wouldn't be looking for a solution but then I wouldn't have learned anything. So... If anyone cares to contribute please do. Dave
Option Base 1
Public Uf
Dim ttt(3, 3) As Variant
Dim cletter As String, pletter As String
Public Sub Tictactoe()
'Plays tictactoe in range A1:C3
Dim cttt(9) As Variant, tie As Integer, 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
Set WsShell = CreateObject("WScript.Shell")
intText = WsShell.Popup("IT'S YOUR TURN!", 2, "HURRY UP!")
Set WsShell = Nothing
'MsgBox "Hurry up! It's your turn"
GoTo before
End If
End Function
Function makemove()
'randomly generate computer move
Dim Xoplace As Integer
Randomize
Do
Xoplace = Int((9 * Rnd) + 1)
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
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
Edit: I don't know how to adjust the code to fix the screen resolution ... whoops on the post but if someone can fix that please do
'on computer move:
'randomly select number and place if it meets conditions:
'starting or tieing move(Tie:1 or 9) ie. exit
'UDFWinit: check for 2 computer X/O's together or spaced apart
'UDFBlockit: check for 2 player O/X's together or spaced apart
'UDFStrategy: place computer X/O beside another X/O
'else: randomly select another number
'loop until X placed
I'm also quite sure had I hit the search button enough times I wouldn't be looking for a solution but then I wouldn't have learned anything. So... If anyone cares to contribute please do. Dave
Option Base 1
Public Uf
Dim ttt(3, 3) As Variant
Dim cletter As String, pletter As String
Public Sub Tictactoe()
'Plays tictactoe in range A1:C3
Dim cttt(9) As Variant, tie As Integer, 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
Set WsShell = CreateObject("WScript.Shell")
intText = WsShell.Popup("IT'S YOUR TURN!", 2, "HURRY UP!")
Set WsShell = Nothing
'MsgBox "Hurry up! It's your turn"
GoTo before
End If
End Function
Function makemove()
'randomly generate computer move
Dim Xoplace As Integer
Randomize
Do
Xoplace = Int((9 * Rnd) + 1)
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
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
Edit: I don't know how to adjust the code to fix the screen resolution ... whoops on the post but if someone can fix that please do