Greating game on visual basic with multiplayer system (стр. 1 из 3)
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