Greating game on visual basic with multiplayer system

AUTOMATIC SYSTEM GREATING GAME ON VISUAL BASIInterface 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-00A0C9E01 368}" '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