p align="left">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
Страницы: 1, 2, 3, 4
|