Greating game on visual basic with multiplayer system (стр. 3 из 3)

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