Лабораторная работа: Greating game on visual basic with multiplayer system
AUTOMATIC SYSTEM
GREATING GAME ON VISUAL BASIC WITH MULTIPLAYER SYSTEM
Dushanbe, 2009
Main Interface
Source Code
Public lanchoice As Long 'address
Public details As String 'names
Public connected As Boolean 'if connected
Private Sub Form_Load ()
Connect. Icon = LoadResPicture ("ictac", vbResIcon) 'form icon
If usermode = "host" Then
join. Enabled = False
Else
host. Enabled = False
gamename. Visible = False
Label5. Visible = False
End If
End Sub
Private Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
'call on form cancel or exit by control box on form
If connectionmade = False Then
MainBoard. hostagame. Enabled = True
MainBoard. joinagame. Enabled = True
Call CloseDownDPlay
multiplayermode = False
End If
MainBoard. Enabled = True
End Sub
Private Sub host_Click ()
On Error GoTo NO_Hosting ' error handler in case creating host fails
If playersname = "" Or gamename = "" Then
MsgBox "You must enter a Players name and Game Name", vbOKOnly, "Tic Tac Oops"
Exit Sub
End If
Call goplay 'starts direct play object
Dim address As DirectPlayAddress
'Selects which choice was made for lan
Set address = EnumConnect. GetAddress (lanchoice)
'Binds address to directplay connection
Call dxplay. InitializeConnection (address)
'Starts sessiondata information
Dim SessionData As DirectPlaySessionData
Set SessionData = dxplay. CreateSessionData
Call SessionData. SetMaxPlayers (2)
Call SessionData. SetSessionName (gamename. Text)
Call SessionData. SetFlags (DPSESSION_MIGRATEHOST)
Call SessionData. SetGuidApplication (AppGuid)
'Starts a new session initializes connection
Call dxplay. Open (SessionData, DPOPEN_CREATE)
'Create Player profile
Dim PlayerName As String
Dim playerhandle As String
PlayerName = playersname. Text
profilename = PlayerName
playerhandle = "Player (Host)"
MyPlayer = dxplay. CreatePlayer (PlayerName, playerhandle, 0, 0)
dxHost = True
gameopen. Caption = gamename. Text
Call updatedisplay 'Updates game list
Label8. Caption = "Waiting for other Players"
Exit Sub
NO_Hosting:
MsgBox "Could not Host Game", vbOKOnly, "Try Again"
End Sub
Private Sub join_Click ()
On Error GoTo Oops
Call goplay
Dim address As DirectPlayAddress
Set address = EnumConnect. GetAddress (lanchoice)
Call dxplay. InitializeConnection (address)
Dim details2 As Byte
Dim SessionData As DirectPlaySessionData
Set SessionData = dxplay. CreateSessionData
'Gets Session any open session info
Set EnumSession = dxplay. GetDPEnumSessions (SessionData, 0, DPENUMSESSIONS_AVAILABLE)
Set SessionData = EnumSession. GetItem (1)
'Get open session name
details = SessionData. GetSessionName
If details > "" And usermode = "client" Then
joingame. Enabled = True
End If
Call updatedisplay
gameopen. Caption = details
Exit Sub
Oops:
MsgBox "Connection Failed", vbOKOnly, "Tic Tac Oops"
Exit Sub
End Sub
Public Function goplay ()
Set dxplay = dx7. DirectPlayCreate ("") 'open directplay object
'gets connection types
Set EnumConnect = dxplay. GetDPEnumConnections ("", DPCONNECTION_DIRECTPLAY)
End Function
Private Sub joingame_Click ()
On Error GoTo Joinfailed
If playersname = "" Then
MsgBox "You must enter a Players name", vbOKOnly, "Tic Tac Oops"
Exit Sub
End If
Dim SessionData As DirectPlaySessionData
Set SessionData = EnumSession. GetItem (1)
'Joins open session
Call dxplay. Open (SessionData, DPOPEN_JOIN)
'creats and sends player info
PlayerName = playersname. Text
profilename = PlayerName
playerhandle = "Player (Client)"
MyPlayer = dxplay. CreatePlayer (PlayerName, playerhandle, 0, 0)
Call UpdateWaiting
joingame. Enabled = False
playersname. Enabled = False
MainBoard. mnuchat. Enabled = True
Exit Sub
Joinfailed:
MsgBox "Joining Session Failed", vbOKOnly, "No Session Found"
Exit Sub
End Sub
Public Sub UpdateWaiting ()
Dim StatusMsg As String
Dim x As Integer
Dim objDPEnumPlayers As DirectPlayEnumPlayers
Dim SessionData As DirectPlaySessionData
' Enumerate players
On Error GoTo ENUMERROR
Set objDPEnumPlayers = dxplay. GetDPEnumPlayers ("", 0)
gNumPlayersWaiting = objDPEnumPlayers. GetCount
' Update label
Set SessionData = dxplay. CreateSessionData
Call dxplay. GetSessionDesc (SessionData)
StatusMsg = gNumPlayersWaiting & " of " & SessionData. GetMaxPlayers _
& " players ready..."
Label8. Caption = StatusMsg
If gNumPlayersWaiting = SessionData. GetMaxPlayers And usermode = "host" Then
start. Enabled = True
Label8. Caption = "Everyone is here Click Start"
End If
If gNumPlayersWaiting = SessionData. GetMaxPlayers And usermode = "client" Then
start. Enabled = False
Label8. Caption = "Waiting For Host To Start Session"
End If
' Update listbox
Dim PlayerName As String
For x = 1 To gNumPlayersWaiting
PlayerName = objDPEnumPlayers. GetShortName (x)
If PlayerName <> playersname. Text Then
labeljoined. Caption = PlayerName & " has joined the game."
opponentsname = PlayerName
End If
Call lstPlayers. AddItem (PlayerName)
Next x
Exit Sub
ENUMERROR:
MsgBox ("No Players Found")
Exit Sub
End Sub
Private Sub lantype_Click (Index As Integer)
lanchoice = Index + 1
host. Visible = True
join. Visible = True
End Sub
Private Sub start_Click ()
On Error GoTo CouldNotStart
Const msgsize = 21
Dim tnumplayers As DirectPlayEnumPlayers
Dim SessionData As DirectPlaySessionData
' Disable joining, in case we start before maximum no. of players reached. We
' don't want anyone slipping in at the last moment.
Set SessionData = dxplay. CreateSessionData
Call dxplay. GetSessionDesc (SessionData) ' necessary?
Call SessionData. SetFlags (SessionData. GetFlags + DPSESSION_JOINDISABLED)
Call dxplay. SetSessionDesc (SessionData)
' Set global player count. This mustn't be done earlier, because someone might
' have dropped out or joined just as the host clicked Start.
Set tnumplayers = dxplay. GetDPEnumPlayers ("", 0)
numplayers = CByte (tnumplayers. GetCount)
Dim dpmsg As DirectPlayMessage
Dim pID As Long
Dim msgtype As Long
Dim x As Byte
Set dpmsg = dxplay. CreateMessage
dpmsg. WriteLong (MSG_STARTGAME) 'case selector
dpmsg. WriteByte (numplayers) 'number of players
Dim PlayerID As Long
For x = 0 To numplayers - 1
PlayerID = tnumplayers. GetDPID (x + 1)
dpmsg. WriteLong (PlayerID)
' Keep local copy of player IDs
PlayerIDs (x) = PlayerID
' Assign place in order to the host
If PlayerID = MyPlayer Then dxMyTurn = x
Next x
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg)
Hide
MainBoard. Enabled = True
MainBoard. Show
MainBoard. playerdisplaylabel. Caption = opponentsname & " Has Joined The Game"
MainBoard. StatusBar1. SimpleText = opponentsname & "Is Ready To Play, Start Game"
MainBoard. mnudisconnect. Enabled = True
connectionmade = True
multiplayermode = True
MainBoard. mnuchat. Enabled = True
onconnect = True
Exit Sub
CouldNotStart:
MsgBox "Could not start game. ", vbOKOnly, "System"
End Sub
Private Function updatedisplay ()
label7. Visible = True
gameopen. FontUnderline = False
gameopen. ForeColor = vbBlue
host. Enabled = False
join. Enabled = False
Dim Y As Byte
Y = 0
For Y = 0 To 2 Step 1
lantype (Y). Enabled = False
Next Y
End Function
Option Explicit
Dim a (9) As Integer
Dim Player_A (9) As Integer 'Initialize X array
Dim Computer_A (9) As Integer 'Initialize O array
Dim Test_Result (8) As Integer
Dim Win (3) As Integer ' Spots won to marked
Dim m, Token, first_turn, temp1 As Integer
Dim Temp As Boolean 'check whether player won
Dim Sq_Left, n1, mark As Integer
Dim tr As String 'string passed on win to mark routine
Dim Begin As Boolean 'continue winning spots flashing
Dim sw As Boolean 'Sets whether X or O starts game
Public Sub Initialize ()
' select who's turn
If usermode = "host" And multiplayermode = True Then
' set o or x first
If sw = True Then
MyTurn = True
Else
MyTurn = False
End If
End If
If multiplayermode = False Then
MyTurn = True
End If
Begin = False ' cancel marking routine
score = score + 1 'adds one to gamecount
If multiplayermode = True Then
If usermode = "client" And sw = True Then
MyTurn = False
ElseIf usermode = "client" And sw = False Then
MyTurn = True
End If
End If
'Start SW true mode**********************************
'initialize game settings
If sw = True Then
StatusBar1. SimpleText = "New Game Initialized" & " X's Turn"
Debug. Print "Turn Status " & MyTurn
Debug. Print "SW Value is " & sw
Dim u As Integer
u = 0
Sq_Left = 9
Token = 10
For u = 0 To 8
Layer_A (u). MousePointer = vbCustom
'select starting icon and characteristics****************************
If usermode = "host" Then
Layer_A (u). MouseIcon = LoadResPicture ("x", vbResIcon)
Else
Layer_A (u). MouseIcon = LoadResPicture ("nyt", vbResIcon)
End If
Layer_A (u). FontSize = 28
Layer_A (u). FontBold = True
Layer_A (u). Caption = ""
Layer_A (u). BackStyle = 0
Layer_A (u). Alignment = 2
Player_A (u) = 0
Computer_A (u) = 0
Layer_A (u). Enabled = True
Next u
'update statusbar and display routine******************************
If usermode = "host" And multiplayermode = True Then
StatusBar1. SimpleText = "New Game Initialized " & profilename & "'s Turn"
Out_Box. Caption = profilename & "'s Turn."
End If
If usermode = "client" And multiplayermode = True Then
StatusBar1. SimpleText = "New Game Initialized " & opponentsname & "'s Turn"
Out_Box. Caption = opponentsname & "'s Turn."
End If
If multiplayermode = False Then
Out_Box. Caption = "X Goes First"
End If
End If
'End sw true*********************************************
'set starting icon*****************
If sw = False Then
StatusBar1. SimpleText = "New Game Initialized" & " O's Turn"
Debug. Print "Turn Status " & MyTurn
Debug. Print "SW Value is " & sw
u = 0
Sq_Left = 9
Token = 10
For u = 0 To 8
Layer_A (u). MousePointer = vbCustom
If usermode = "host" And multiplayermode = True Then
Layer_A (u). MouseIcon = LoadResPicture ("nyt", vbResIcon)
Else
Layer_A (u). MouseIcon = LoadResPicture ("o", vbResIcon)
End If
Layer_A (u). FontSize = 28
Layer_A (u). FontBold = True
Layer_A (u). Caption = ""
Layer_A (u). BackStyle = 0
Layer_A (u). Alignment = 2
Player_A (u) = 0
Computer_A (u) = 0
Layer_A (u). Enabled = True
Next u
Temp = False 'initiate no win
'Update Statusbar and outbox display********************8
If usermode = "client" And multiplayermode = True Then
StatusBar1. SimpleText = "New Game Initialized " & profilename & "'s Turn"
Out_Box. Caption = profilename & " 's Turn."
End If
If usermode = "host" And multiplayermode = True Then
StatusBar1. SimpleText = "New Game Initialized " & opponentsname & "'s Turn"
Out_Box. Caption = opponentsname & " 's Turn."
End If
If multiplayermode = False Then
Out_Box. Caption = "O Goes First"
End If
End If
'End sw false*********************************************
Debug. Print "Ran Initialization Myturn status is " & MyTurn
Game_Over. Caption = "New Game"
End Sub
Private Sub exit_Click ()
If onconnect = True Then 'checks for connection
On Error GoTo NoDx 'error to handle dxplay not initialized
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_STOP) 'Sends player quit message to other player
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg)
Call CloseDownDPlay 'shuts down dxplay
End If
Unload Connect 'unloads connect form if connect frees memory
Unload MainBoard 'unloads board before ending to free memory
End
NoDx:
MsgBox "Could not stop DXPlay. ", vbOKOnly, "System"
End
End Sub
Private Sub Form_Load ()
On Error GoTo NoLoad 'Handles errors in case form won't load
MainBoard. Icon = LoadResPicture ("ictac", vbResIcon) 'form icon
restart. Visible = False 'restart button not seen on single player or client mode
mnudisconnect. Enabled = False 'set menu item to no connect state
onconnect = False 'Sets connection status to false by default
sw = True 'set starting Player to x
x. Checked = True 'set menuitem X to x checked
multiplayermode = False 'initiate mode to false
Call deinitialize 'disables all squares until gamemode and multiplayer mode is decided
score = 0 'sets game count to 0
Exit Sub
NoLoad:
MsgBox "Could Not Load Form", vbOKOnly, "Quitting"
End
End Sub
Private Sub deinitialize ()
'Disables all squares until game selection is made
Dim m As Integer
For m = 0 To 8
Layer_A (m). MousePointer = vbCustom
If sw = True Then 'sets mouse pointer to x for x first
Layer_A (m). MouseIcon = LoadResPicture ("x", vbResIcon)
Else 'sets mouse pointer to O for O first
Layer_A (m). MouseIcon = LoadResPicture ("o", vbResIcon)
End If
Layer_A (m). FontSize = 28
Layer_A (m). FontBold = True
Layer_A (m). Caption = ""
Layer_A (m). BackStyle = 0
Layer_A (m). Alignment = 2
Layer_A (m). Enabled = False
Next m
'Update Status Bar
StatusBar1. SimpleText = "Select Game - New Game or Multiplayer option to start game"
Out_Box. Caption = "Start New Game."
End Sub
Private Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
If onconnect = True Then
On Error GoTo NoDx
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_STOP)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg)
Call CloseDownDPlay
End If
Unload Connect
Unload MainBoard
End
NoDx:
MsgBox "Could not stop DXPlay. ", vbOKOnly, "System"
End
End Sub
Private Sub hostagame_Click ()
usermode = "host" 'Sets usermode to host
Connect. Show 'starts connect form
MainBoard. Enabled = False 'disable form so user cannot select while connect form is up
hostagame. Enabled = False 'disables menu host button.
joinagame. Enabled = False ' disables menu join button
multiplayermode = True 'sets multiplayer to true
End Sub
Private Sub joinagame_Click ()
usermode = "client" 'Sets usermode to client
Connect. Show
MainBoard. Enabled = False
multiplayermode = True
End Sub
Private Sub Layer_A_Click (Index As Integer)
playerdisplaylabel. Caption = ""
'Used For single player board selection or multiplayer your turn selection
Debug. Print "Layer A Click Turn Status " & MyTurn
Debug. Print "Layer A Multiplayer Mode Status " & multiplayermode
If multiplayermode = True And MyTurn = False Then 'Easy way to exit if not your turn
Exit Sub
End If
If Sq_Left Mod 2 = 1 Then 'check remainder of squares left divided by 2
If sw = True Then ' sets who goes first X or O
Layer_A (Index). Caption = "X"
Else
Layer_A (Index). Caption = "O"
End If
Layer_A (Index). Enabled = False 'Sets selected square to not available
Player_A (Index) = 1
Computer_A (Index) = - Token
LoadPlayer
If multiplayermode = True And MyTurn = True Then 'checks for multiplayer and turn status
'This routine below packs message to send
'to other player to select the square chosen.
Dim dpmsg As DirectPlayMessage 'alot direct playmessage
Set dpmsg = dxplay. CreateMessage 'set and create the message
Call dpmsg. WriteLong (MSG_MOVE) 'pack message structure and identify type
Call dpmsg. WriteByte (Index) 'Packs case selection number to msgtype.
'This sends the pack message structure
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg)
End If
If multiplayermode = True Then 'Sets routines to not your turn on multiplayer
Dim Y As Integer
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("nyt", vbResIcon)
Next Y
'Update Status displays
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & opponentsname & "'s Turn"
Out_Box. Caption = opponentsname & "'s Turn."
End If
'Everything below until mod else statement is single player
If multiplayermode = False Then 'Sets X or O turn status on single player
If sw = True Then
StatusBar1. SimpleText = "New Game Initialized O's Turn"
Else
StatusBar1. SimpleText = "New Game Initialized X's Turn"
End If
If sw = True Then
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Next Y
Else
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Next Y
End If
If sw = True Then
Out_Box. Caption = "O's Turn"
Else
Out_Box. Caption = "X's Turn"
End If
End If
Else
'Mod else*********************************
If sw = True Then
Layer_A (Index). Caption = "O"
Else
Layer_A (Index). Caption = "X"
End If
Layer_A (Index). Enabled = False
Player_A (Index) = - Token
Computer_A (Index) = 1
If multiplayermode = True Then
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & opponentsname & "'s Turn"
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("nyt", vbResIcon)
Next Y
Out_Box. Caption = opponentsname & "'s Turn."
End If
If multiplayermode = False Then
If sw = True Then
StatusBar1. SimpleText = "New Game Initialized X's Turn"
Else
StatusBar1. SimpleText = "New Game Initialized O's Turn"
End If
If sw = True Then
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Next Y
Out_Box. Caption = "X's Turn"
Else
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Next Y
Out_Box. Caption = "O's Turn"
End If
End If
LoadComputer
If multiplayermode = True And MyTurn = True Then
'Same as above packs message and sends move to other player
Dim dpmsg2 As DirectPlayMessage
Set dpmsg2 = dxplay. CreateMessage
Call dpmsg2. WriteLong (MSG_MOVE)
Call dpmsg2. WriteByte (Index)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg2)
End If
End If
Sq_Left = Sq_Left - 1
EvalNextMove
MyTurn = False
End Sub
Public Function layer_A_online (Index As Integer)
playerdisplaylabel. Caption = ""
'This routine is called to mark sqares when remote computer
'sends a move made command.
'Same as above with some redundant routines removed
If Sq_Left Mod 2 = 1 Then
If sw = True Then
Layer_A (Index). Caption = "X"
Else
Layer_A (Index). Caption = "O"
End If
Layer_A (Index). Enabled = False
Player_A (Index) = 1
Computer_A (Index) = - Token
If multiplayermode = True Then
If sw = True Then
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
Out_Box. Caption = profilename & "'s Turn."
Dim Y As Integer
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Next Y
Else
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
Out_Box. Caption = profilename & "'s Turn."
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Next Y
End If
End If
If multiplayermode = False Then
If sw = True Then
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Out_Box. Caption = "O's Turn"
Next Y
Else
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Out_Box. Caption = "X's Turn"
Next Y
End If
End If
LoadPlayer
Else
If sw = True Then
Layer_A (Index). Caption = "O"
Else
Layer_A (Index). Caption = "X"
End If
Layer_A (Index). Enabled = False
Player_A (Index) = - Token
Computer_A (Index) = 1
If multiplayermode = True Then
If sw = True Then
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
Out_Box. Caption = profilename & "'s Turn."
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Next Y
Else
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
Out_Box. Caption = profilename & "'s Turn."
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Next Y
End If
End If
If multiplayermode = False Then
If sw = True Then
StatusBar1. SimpleText = "New Game Initialized X's Turn"
Else
StatusBar1. SimpleText = "New Game Initialized O's Turn"
End If
If sw = True Then
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("x", vbResIcon)
Next Y
Out_Box. Caption = "X's Turn"
Else
Y = 0
For Y = 0 To 8
Layer_A (Y). MouseIcon = LoadResPicture ("o", vbResIcon)
Next Y
Out_Box. Caption = "O's Turn"
End If
End If
LoadComputer
End If
Sq_Left = Sq_Left - 1
EvalNextMove
End Function
Private Sub scan_3 () '*****************************************
Dim r As Integer
For r = 0 To 7
If Test_Result (r) = 3 Then
Temp = True
End If
Next r
End Sub
Private Sub EvalNextMove () '***********************************
test
scan_3
Debug. Print "Squares Left Value on Evaluate Next Move " & Sq_Left
Debug. Print "Boolean Temp Value on Evaluate " & Temp
Debug. Print "Token Value on Eval." & Token
If Temp = True Then
If Sq_Left Mod 2 = 0 Then 'Makes win or lose calls Turn checking is made later
Player_Wins 'call player wins routine
Else
Computer_Wins 'calls computer rountine
End If
End If
Temp = False
If Sq_Left <= 0 Then
Cats_Game
Begin = False 'Turns off mark routine
If multiplayermode = True And usermode = "host" Then 'sets turn to true
MyTurn = True
Debug. Print "Set myturn to true on win"
End If
End If
first_turn = 1
End Sub
Private Sub Computer_Wins ()
Dim s As Integer
For s = 0 To 8
Layer_A (s). Enabled = False
Next s
Begin = True
If multiplayermode = True And usermode = "host" Then
If sw = True Then 'Checks for Whos Turn and update Host or client
Out_Box. Caption = opponentsname & " Won!"
opponentsscore = opponentsscore + 1
Else
Out_Box. Caption = profilename & " Won!"
profilenamescore = profilenamescore + 1
End If
End If
If multiplayermode = True And usermode = "client" Then
If sw = True Then
Out_Box. Caption = profilename & " Won!"
profilenamescore = profilenamescore + 1
Else
Out_Box. Caption = opponentsname & " Won!"
opponentsscore = opponentsscore + 1
End If
End If
If multiplayermode = False Then 'Single Player updating
If sw = True Then
Out_Box. Caption = "O Won!!!!"
Else
Out_Box. Caption = "X Won!!!!!"
End If
End If
Game_Over. Caption = "Game Over"
'Shows Resart Option if Host
If multiplayermode = True And usermode = "host" Then
restart. Visible = True
restart. Enabled = True
End If
Timer4. Enabled = True 'Sets timer to time mark routine
If sw = True Then 'Checks Whos turn sends string to mark
Call Mark_Win ("O")
Else
Call Mark_Win ("X")
End If
End Sub
Private Sub Player_Wins ()
'See computer wins for details
Dim a As Integer
For a = 0 To 8
Layer_A (a). Enabled = False
Next a
Begin = True
If multiplayermode = True And usermode = "host" Then
If sw = True Then
profilenamescore = profilenamescore + 1
Out_Box. Caption = profilename & " Won!"
Else
opponentsscore = opponentsscore + 1
Out_Box. Caption = opponentsname & " Won!"
End If
End If
If multiplayermode = True And usermode = "client" Then
If sw = True Then
opponentsscore = opponentsscore + 1
Out_Box. Caption = opponentsname & " Won!"
Else
profilenamescore = profilenamescore + 1
Out_Box. Caption = profilename & " Won!"
End If
End If
If multiplayermode = False Then
If sw = True Then
Out_Box. Caption = "X Won!!!!"
Else
Out_Box. Caption = "O Won!!!!!"
End If
End If
Game_Over. Caption = "Game Over"
If multiplayermode = True And usermode = "host" Then
restart. Visible = True
restart. Enabled = True
End If
Timer4. Enabled = True
If sw = True Then
Call Mark_Win ("X")
Else
Call Mark_Win ("O")
End If
End Sub
Private Sub Mark_Win (tr As String) 'Marks winning squares
Dim PauseTime, start, Finish, TotalTime
While Begin = True
PauseTime = 0.3 ' Set duration.
start = Timer ' Set start time.
Do While Timer < start + PauseTime And Begin = True
For n1 = 0 To 2
mark = Win (n1)
Layer_A (mark). Caption = tr
Layer_A (mark). FontBold = False
Next n1
DoEvents ' Yield to other processes.
Loop
start = Timer ' Set start time.
Do While Timer < start + PauseTime And Begin = True
For n1 = 0 To 2
mark = Win (n1)
Layer_A (mark). FontBold = True
Layer_A (mark). Caption = tr
Next n1
DoEvents ' Yield to other processes.
Loop
Wend
End Sub
Private Sub test () 'Tests conditions for the win
Dim n, k, sample As Integer
sample = 0
For n = 0 To 2
Test_Result (sample) = a (3 * n) + a (3 * n + 1) + a (3 * n + 2)
If Test_Result (sample) = 3 Then
Win (0) = 3 * n
Win (1) = 3 * n + 1
Win (2) = 3 * n + 2
End If
sample = sample + 1
Next n
For n = 0 To 2
Test_Result (sample) = a (n) + a (n + 3) + a (n + 6)
If Test_Result (sample) = 3 Then
Win (0) = n
Win (1) = n + 3
Win (2) = n + 6
End If
sample = sample + 1
Next n
Test_Result (sample) = a (0) + a (4) + a (8)
If Test_Result (sample) = 3 Then
Win (0) = 0
Win (1) = 4
Win (2) = 8
End If
sample = sample + 1
Test_Result (sample) = a (6) + a (4) + a (2)
If Test_Result (sample) = 3 Then
Win (0) = 6
Win (1) = 4
Win (2) = 2
End If
sample = sample + 1
End Sub
Private Sub LoadPlayer ()
Dim e As Integer
For e = 0 To 8
a (e) = Player_A (e)
Next e
End Sub
Private Sub LoadComputer ()
Dim w As Integer
For w = 0 To 8
a (w) = Computer_A (w)
Next w
End Sub
Private Sub Cats_Game () 'Cats Game display routine
GameUnderway = False
Dim z As Integer
For z = 0 To 8
Layer_A (z). Enabled = False
Next z
Out_Box. Caption = "Cat's Game!"
Game_Over. Caption = "Game Over"
If multiplayermode = True And usermode = "host" Then
restart. Visible = True
restart. Enabled = True
End If
End Sub
Private Sub mnuchat_Click () 'Menu button for chatbox routine
On Error GoTo NoChat 'error handler in case chat initialization problem.
If mnuchat. Checked = True Then
Frame1. Visible = False
chatlabel. Visible = False
send_chat. Visible = False
chatbox. Visible = False
mnuchat. Checked = False
'Packs and sends DXplay message to switch chat on off
Dim chaton As DirectPlayMessage
Set chaton = dxplay. CreateMessage
Call chaton. WriteLong (MSG_CHAT_ON)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, chaton)
Else
Frame1. Visible = True
chatlabel. Visible = True
send_chat. Visible = True
chatbox. Visible = True
mnuchat. Checked = True
chatbox. Visible = True
chatbox. SetFocus
'Packs and sends DXplay message to switch chat on off
Dim chaton2 As DirectPlayMessage
Set chaton2 = dxplay. CreateMessage
Call chaton2. WriteLong (MSG_CHAT_ON)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, chaton2)
End If
Exit Sub
NoChat:
MsgBox "Could Not Start Chat", vbOKOnly, "Oops"
Exit Sub
End Sub
Public Function chatswitch () 'Menu button for incoming online Chatbox routine
On Error GoTo NoChat
If mnuchat. Checked = True Then
Frame1. Visible = False
chatlabel. Visible = False
send_chat. Visible = False
chatbox. Visible = False
mnuchat. Checked = False
Else
Frame1. Visible = True
chatlabel. Visible = True
send_chat. Visible = True
chatbox. Visible = True
mnuchat. Checked = True
chatbox. Visible = True
chatbox. SetFocus
End If
Exit Function
NoChat:
MsgBox "Could Not Start Chat", vbOKOnly, "Oops"
Exit Function
End Function
Private Sub mnudisconnect_Click () 'Disconnects and sends disconnect message
mnudisconnect. Enabled = False
newgame. Enabled = True
hostagame. Enabled = True
joinagame. Enabled = True
multiplayermode = False
usermode = "host"
'Sends player has left message to other players
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_STOP)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, dpmsg)
Call CloseDownDPlay
Unload Connect
onconnect = False
End Sub
Private Sub newgame_Click () 'starts new game single or multiplayer
On Error GoTo NoGame
If usermode = "client" And multiplayermode = True Then
MsgBox "Only the host can restart the game. ", vbOKOnly, "Tic Tac Oops"
Exit Sub
End If
If multiplayermode = False Then
usermode = "host"
Call Initialize
Else
Call restart_Click 'call restart routine for multiplayer
End If
Exit Sub
NoGame:
MsgBox "Could Not Start Game. ", vbOKOnly, "Oops"
Exit Sub
End Sub
Public Sub o_Click () 'sets menu item whos first o
If GameUnderway = True Then
MsgBox "You cannot chang this option while a game is in play", vbOKOnly, "Tic Tac Oops"
Exit Sub
End If
If o. Checked = True Then
sw = False
Exit Sub
Else
o. Checked = True
x. Checked = False
sw = False
End If
If multiplayermode = True Then
'Sends who goes first message.
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_XORO)
Call dpmsg. WriteByte (2)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, _
dpmsg)
End If
Debug. Print "menu X or O clicked sw is " & sw
End Sub
Public Sub restart_Click () 'Restarts Game and updates scores
GameUnderway = True
multiplayermode = True
If usermode = "host" Then
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_RESTART)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, _
dpmsg)
End If
Call Initialize
If usermode = "host" Then
If sw = True Then
MyTurn = True
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
playerdisplaylabel. Caption = profilename & "'s Turn."
Else
MyTurn = False
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & opponentsname & "'s Turn"
playerdisplaylabel. Caption = opponentsname & "'s Turn."
End If
End If
If usermode = "client" Then
If sw = True Then
MyTurn = False
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & opponentsname & "'s Turn"
playerdisplaylabel. Caption = opponentsname & "'s Turn."
Else
MyTurn = True
StatusBar1. SimpleText = "Game count is " & score & " " & opponentsname & ": " & opponentsscore & " | " & profilename & ": " & profilenamescore & " " & profilename & "'s Turn"
playerdisplaylabel. Caption = profilename & "'s Turn."
End If
End If
restart. Visible = False
End Sub
Private Sub send_chat_Click ()
'handles chat boxes
Const chatlen = 5 + MChatString
Dim msgdata (chatlen) As Byte
Dim x As Integer
'packs and sends chat box information
Dim cmsg As DirectPlayMessage
Set cmsg = dxplay. CreateMessage
Call cmsg. WriteLong (MSG_CHAT)
Call cmsg. WriteString (chatbox. Text)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, cmsg)
If chatlabel. Text = "" Then
chatlabel. Text = profilename & ": " & chatbox. Text
Else
chatlabel. Text = chatlabel. Text & vbCrLf & profilename & ": " & chatbox. Text
End If
chatbox. Text = ""
End Sub
Private Sub Timer4_Timer ()
GameUnderway = False
'sets begin to false to stop letters from flashing.
'Updates score and status bar.
Begin = False
If usermode = "host" And multiplayermode = True Then
StatusBar1. SimpleText = "Select Restart Game." & "Game #" & score & " " & profilename & ": " & profilenamescore & " " & opponentsname & ": " & opponentsscore
MyTurn = True
ElseIf usermode = "client" And multiplayermode = True Then
StatusBar1. SimpleText = "Waiting on Host To Restart." & "Game #" & score & " " & profilename & ": " & profilenamescore & " " & opponentsname & ": " & opponentsscore
End If
Timer4. Enabled = False
End Sub
Public Sub x_Click () 'handles menu item X whos turn first
If GameUnderway = True Then
MsgBox "You cannot chang this option while a game is in play", vbOKOnly, "Tic Tac Oops"
Exit Sub
End If
If x. Checked = True Then
sw = True
Exit Sub
Else
x. Checked = True
o. Checked = False
sw = True
End If
If multiplayermode = True Then
'Sends who goes first message.
Dim dpmsg As DirectPlayMessage
Set dpmsg = dxplay. CreateMessage
Call dpmsg. WriteLong (MSG_XORO)
Call dpmsg. WriteByte (1)
Call dxplay. Send (MyPlayer, DPID_ALLPLAYERS, DPSEND_GUARANTEED, _
dpmsg)
End If
Debug. Print "menu X or O clicked sw is " & sw
End Sub
Global usermode As String 'sets usermode host or client
Global multiplayermode As Boolean 'Sets multiplayer yes no
Global MyTurn As Boolean 'My turn switch
Global profilename As Variant 'name for your machine
Global opponentsname As Variant 'name for remote machine
Global score As Integer ' keeps track of game score
Global profilenamescore As Integer 'your score
Global opponentsscore As Integer 'remote score
Global sw As Boolean 'set whether x or o goes first
' Constants
Public Const MaxPlayers = 2
Public Const MChatString = 60
' DirectPlay stuff
Public dx7 As New DirectX7
Public dxplay As DirectPlay4
Public EnumConnect As DirectPlayEnumConnections
Public onconnect As Boolean
Public gNumPlayersWaiting As Byte
Public MyPlayer As Long
Public EnumSession As DirectPlayEnumSessions
Public numplayers As Byte
Public dxHost As Boolean
Public CurrentPlayer As Integer
Public PlayerScores (MaxPlayers) As Byte
Public PlayerIDs (MaxPlayers) As Long
Public dxMyTurn As Integer
Public GameUnderway As Boolean
Public connectionmade As Boolean
'The appguid number was generated with the utility provide with DX7 SDK.
Public Const AppGuid = "{D4D5D10B-7D04-11D3-8E64-00A0C9E01368}"
'This defines the msgtype you will send with DXplay. send
Public Enum MSGTYPES
MSG_STOP 'Handles user diconnect
MSG_STARTGAME 'Startgame
MSG_CHAT_ON 'Chat on or off
MSG_CHAT 'chat input
MSG_RESTART 'Restart Game
MSG_XORO 'Select if X or O Starts game
MSG_MOVE 'What square selected
End Enum
Public Sub CloseDownDPlay () 'this shuts down directplay
dxHost = False
GameUnderway = False
Set EnumConnect = Nothing
Set EnumSession = Nothing
Set dxplay = Nothing
End Sub
' Main procedure. This is where we poll for DirectPlay messages in idle time.
Public Sub Main ()
MainBoard. Show
Do While DoEvents () ' allow event processing while any windows open
DPInput
Loop
End Sub
' Receive and process DirectPlay Messages
Public Sub DPInput ()
Dim FromPlayer As Long
Dim ToPlayer As Long
Dim msgsize As Long
Dim msgtype As Long
Dim dpmsg As DirectPlayMessage
Dim MsgCount As Long
Dim msgdata () As Byte
Dim x As Integer
Dim fromplayername As String
If dxplay Is Nothing Then Exit Sub 'IF single player then exit
On Error GoTo NOMESSAGE
' If this call fails, presumably it's because there's no session or
' no player.
MsgCount = dxplay. GetMessageCount (MyPlayer) 'Get number of messages.
On Error GoTo MSGERROR
Do While MsgCount > 0 'Read all messages
Set dpmsg = dxplay. Receive (FromPlayer, ToPlayer, DPRECEIVE_ALL) 'Read DXINput
msgtype = dpmsg. ReadLong () 'Read DXinput msg TYPE
MsgCount = MsgCount - 1
'Direct X System Only Messages not user defineable
If FromPlayer = DPID_SYSMSG Then
Select Case msgtype
' New player, update player list
Case DPSYS_DESTROYPLAYERORGROUP, _
DPSYS_CREATEPLAYERORGROUP
If Connect. Visible Then Connect. UpdateWaiting 'update connection sessions list
Case DPSYS_HOST 'either lost connection or changed you to host
dxHost = True
If Connect. Visible Then
MsgBox ("You are now the host. ")
Connect. UpdateWaiting ' make sure Start button is enabled
End If
End Select
' - --------------------------------------------------------------------------------------
' User specified Message Structure TYPES
Else
' Get name of sending player
If onconnect = False Then
fromplayername = dxplay. GetPlayerFriendlyName (FromPlayer) 'Gets name
opponentsname = fromplayername 'changes to games variable
'Updates status bars and labels.
If usermode = "host" Then
MainBoard. playerdisplaylabel. Caption = opponentsname & " Has Joined The Game"
MainBoard. StatusBar1. SimpleText = opponentsname & "Is Ready To Play, Start Game"
End If
If usermode = "client" Then
MainBoard. playerdisplaylabel. Caption = "You Have Joined " & opponentsname & "'s Game"
MainBoard. StatusBar1. SimpleText = opponentsname & " Will Start The Game"
End If
End If
onconnect = True
Select Case msgtype
'Below is where you define your message structure types and add responding code, cool.
Case MSG_STARTGAME
onconnect = True
multiplayermode = True
' Number of players
numplayers = dpmsg. ReadByte
' Player IDs,
MyPlayer = dpmsg. ReadLong
' Show the game board.
Connect. Hide
MainBoard. Enabled = True
MainBoard. Show
MainBoard. hostagame. Enabled = False
MainBoard. joinagame. Enabled = False
MainBoard. mnudisconnect. Enabled = True
Case MSG_MOVE 'Sent when square is click
Dim t As Byte
t = dpmsg. ReadByte
Select Case t
Case 0
Call MainBoard. layer_A_online (0)
Case 1
Call MainBoard. layer_A_online (1)
Case 2
Call MainBoard. layer_A_online (2)
Case 3
Call MainBoard. layer_A_online (3)
Case 4
Call MainBoard. layer_A_online (4)
Case 5
Call MainBoard. layer_A_online (5)
Case 6
Call MainBoard. layer_A_online (6)
Case 7
Call MainBoard. layer_A_online (7)
Case 8
Call MainBoard. layer_A_online (8)
End Select
MyTurn = True
Case MSG_CHAT_ON 'Handles Turn chat on off
Call MainBoard. chatswitch
Case MSG_XORO 'Selects who goes first X or O
Dim thing As Byte
thing = dpmsg. ReadByte
If thing = 1 Then
Call MainBoard. x_Click
End If
If thing = 2 Then
Call MainBoard. o_Click
End If
Case MSG_RESTART 'handles input for restart
multiplayermode = True
MainBoard. playerdisplaylabel. Caption = opponentsname & " has restarted the game."
If sw = True Then
MyTurn = False
Else
MyTurn = True
End If
Call MainBoard. restart_Click
Case MSG_CHAT 'Handles Chat String input
Dim chatin As String
chatin = dpmsg. ReadString ()
If MainBoard. chatlabel. Text = "" Then
MainBoard. chatlabel. Text = opponentsname & ": " & chatin
Else
MainBoard. chatlabel. Text = MainBoard. chatlabel. Text & vbCrLf & opponentsname & ": " & chatin
End If
Case MSG_STOP 'Handles player disconnected.
MsgBox opponentsname & " has left the game. ", vbOKOnly, "Tic Tac Oops"
MainBoard. mnudisconnect. Enabled = False
MainBoard. newgame. Enabled = True
MainBoard. hostagame. Enabled = True
MainBoard. joinagame. Enabled = True
multiplayermode = False
usermode = "host"
Call CloseDownDPlay
Unload Connect
onconnect = False
End Select
End If
Loop
Exit Sub
' Error handlers
MSGERROR:
MsgBox ("Error reading message. ")
CloseDownDPlay
End
NOMESSAGE:
Exit Sub
End Sub
INTERFACE
