Смекни!
smekni.com

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

AUTOMATIC SYSTEM

GREATING GAME ON VISUAL BASIC WITH MULTIPLAYER SYSTEM

Dushanbe, 2009


Main Interface

Greating game on visual basic with multiplayer system

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