Greating game on visual basic with multiplayer system

БОЛЬШАЯ ЛЕНИНГРАДСКАЯ БИБЛИОТЕКА - РЕФЕРАТЫ - Greating game on visual basic with multiplayer system

Greating game on visual basic with multiplayer system

2

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