46570 (Greating game on visual basic with multiplayer system), страница 3

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