form1.frm

用于远程视频监控的源码

      End
      Begin VB.Menu mnudash 
         Caption         =   "-"
      End
      Begin VB.Menu mnuexittag 
         Caption         =   "E&xit TAG"
      End
   End
   Begin VB.Menu mnutophelp 
      Caption         =   "Help"
      Visible         =   0   'False
      Begin VB.Menu mnuAbout 
         Caption         =   "&About..."
      End
      Begin VB.Menu mnuhelp 
         Caption         =   "&Help..."
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
 '#########################################################
'### NOTE TO VIEWERS...                                  ###
'### If your looking for the WINSOCK part                ###
'###  of this code, it in the WS object                  ###
'### with the Connect, DataArival, and ConnectionRequest ###
'### Declarations.                                       ###
'###                                                     ###
'### KNOWN BUGS...                                       ###
'###  First of all, the game gets thrown out of sync     ###
'###  really easily because the speed of calculations    ###
'###  wich the computer does.  Other bugs with incomming ###
'###  data HAVE been noted adn hopefully fixed.          ###
'### SEE THE README FILE for information on how it works ###
'###    please also note that it will not let you move   ###
'###   unless you are connected to an opponent
'###     http://www.yarinteractive.com                   ###
 '#########################################################
Public Flag1 As Boolean
Public lastkey As Integer

Public Sub CmdSend_Click()
Dim b
If ConnectedtoRemote = False Then
TypeMatrix "Message not sent, not connected to remote computer..."
ElseIf ConnectedtoRemote = True And Len(txtTransmit.Text) > 0 Then
ws.SendData "%YTT%" & txtTransmit.Text 'send a transmission... (chat)
TypeMatrix MyTagName & ": " & txtTransmit.Text
txtTransmit.Text = ""
End If
End Sub

Private Sub Form_Load()
'Some more stuff that could be improved upon..
mmStop
mmClose
mmOpen (App.Path + "\sounds\mission.mid")
'MsgBox "It should be playing music!!!"
mmPlay

Paused = False
Timer1.Enabled = True
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
resmenus 'reset the menus
End Sub

Private Sub Form_Terminate()
mmStop
  mmClose
End Sub

Private Sub Form_Unload(Cancel As Integer)
mmStop 'stop all of the multimedia stuff
  mmClose
End Sub

Private Sub lblX_Click()
WEndGame
End Sub

Private Sub lblX_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
shpdd.Visible = False 'get rid of the box thing
lblX.BackStyle = 1 'show the background
lblX.ForeColor = 0
End Sub

Private Sub MatrixTextTimer_Timer()
If mlength = Len(MatrixText) Then MatrixTextTimer.Enabled = False
mlength = mlength + 1
lblTr.Caption = Mid(MatrixText, 1, mlength)
End Sub

Private Sub mnupause_Click()
If Paused = False Then
Paused = True
  Call WPauseGame 'if we're not paused, pause it...
 ElseIf Paused = True Then
 Paused = False
  Call WUnPauseGame 'if we're paused, unpause it...
End If
End Sub

Private Sub PArena_KeyDown(KeyCode As Integer, Shift As Integer)
'CircDirection
'1 = left   Chr(37)
'2 = up     Chr(38)
'3 = right  Chr(39)
'4 = down   Chr(40)
If ConnectedtoRemote = True Then
 Select Case KeyCode
     Case 37 'if they press left
     If lastkey = 37 Then Exit Sub
     ' ws.Close
      ws.SendData "YTDIR1"
        CircDirection = 1
     Case 38 'if they pressed up
     If lastkey = 38 Then Exit Sub
        ws.SendData "YTDIR2"
        CircDirection = 2
       'lblTr.Caption = "poop!!!"
     Case 39 'if they pressed right
     If lastkey = 39 Then Exit Sub
        ws.SendData "YTDIR3"
        CircDirection = 3
     Case 40 'if they pressed down
     If lastkey = 40 Then Exit Sub
       ws.SendData "YTDIR4"
        CircDirection = 4
     Case 80
      If Paused = False Then
         WPauseGame
        ElseIf Paused = True Then
         WUnPauseGame
      End If
    End Select
lastkey = KeyCode
End If
End Sub

Private Sub picMoveF_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MX
m = X
resmenus 'reset the menus
If Button = 1 Then
 Form1.Left = (Form1.Left + (X))
 Form1.Top = (Form1.Top + (Y))
End If
End Sub

Private Sub PArena_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
resmenus 'reset the menus...
End Sub

Private Sub pmnugame_Click()
PopupMenu mnugame 'show the popup menu
End Sub

Private Sub pmnugame_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
pMnuHelp.BackStyle = 0 'set the other menu object's background to transparent
  pMnuHelp.ForeColor = &HFFFFFF 'set the other menu's forecolor to white again

  pmnugame.BackStyle = 1
pmnugame.ForeColor = 0
End Sub

Private Sub pMnuHelp_Click()
PopupMenu mnutophelp 'show the HELP popup...
End Sub

Private Sub pMnuHelp_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
pmnugame.BackStyle = 0 'set the other menu object's background to transparent
  pmnugame.ForeColor = &HFFFFFF 'set the other menu's forecolor to white again

  pMnuHelp.BackStyle = 1
pMnuHelp.ForeColor = 0
End Sub

Public Sub resmenus() 'procedure to reset the menus...
pmnugame.BackStyle = 0 'set the other menu object's background to transparent
  pmnugame.ForeColor = &HFFFFFF 'set the other menu's forecolor to white again

  pMnuHelp.BackStyle = 0 'set the other menu object's background to transparent
  pMnuHelp.ForeColor = &HFFFFFF 'set the other menu's forecolor to white again
  
  lblX.BackStyle = 0
  shpdd.Visible = True
  lblX.ForeColor = &HFFFFFF
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
  Case 13 'if they pressed enter then...
   Call CmdSend_Click
  End Select
End Sub

Private Sub Timer1_Timer()
'if anyone could figure out a quicker way of calculating this
'let me know, cuz right now the slow calculations run the game
'out of sync, on any computer from a 100Mhz to a PIII 800Mhz!!!
On Error Resume Next
If Paused = True Then Exit Sub

If CircDirection = 1 And CircX > LeftBound Then
CircX = CircX - CircSpeed
Circle1.Left = CircX
ElseIf CircDirection = 3 And CircX < (RightBound - CircSize) Then
CircX = CircX + CircSpeed
Circle1.Left = CircX
ElseIf CircDirection = 4 And CircY < (BottomBound - CircSize) Then
CircY = CircY + CircSpeed
Circle1.Top = CircY
ElseIf CircDirection = 2 And CircY > TopBound Then
CircY = CircY - CircSpeed
Circle1.Top = CircY
Else
CircDirection = RevDir(CircDirection)
ws.SendData "YTDIR" & CircDirection
End If

If OpCircDir = 1 And OpCircX > LeftBound Then
OpCircX = OpCircX - OpCircSpeed
Circle2.Left = OpCircX

ElseIf OpCircDir = 3 And OpCircX < (RightBound - CircSize) Then
OpCircX = OpCircX + OpCircSpeed
Circle2.Left = OpCircX

ElseIf OpCircDir = 4 And OpCircY < (BottomBound - CircSize) Then
OpCircY = OpCircY + OpCircSpeed
Circle2.Top = OpCircY

ElseIf OpCircDir = 2 And OpCircY > TopBound Then
OpCircY = OpCircY - OpCircSpeed
Circle2.Top = OpCircY
End If
If YourIt = True Then DoCalcs
End Sub


Private Sub txtTransmit_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then Call CmdSend_Click
End Sub

Private Sub ws_Connect()
TypeMatrix "Conneting... Vairifying connection..."
ws.SendData "%YTCON?%" 'send varification request string...
TypeMatrix "Varification Request sent, waiting for reply..."
'send the name...
lblTr.Caption = "Sending Name..."
ws.SendData "YTPNAM" & MyTagName & "%"

'send our color
lblTr.Caption = "Sending Color..."
ws.SendData "%YTPCO" & MyColorNum & "%"

lblTr.Caption = "Sending Player Color..."

'varify once more..
lblTr.Caption = "Game Started..."

'Enable Chat...
txtTransmit.Enabled = True
Paused = False
Timer1.Enabled = True
ConnectedtoRemote = True

'Set up stuff for being the host...
CircX = 525
CircY = 1806
Circle1.Left = CircX
Circle1.Top = CircY
OpCircX = 4155
OpCircY = 1620
Circle2.Left = OpCircX
Circle2.Top = OpCircY
MsgBox "Set up default shit!"
End Sub

Private Sub ws_ConnectionRequest(ByVal requestID As Long)
Dim m
m = MsgBox("Player found...  Do you wish to accept the connection?", vbYesNo, "Accept Connection?")
If m = vbYes Then
'MsgBox "Connection Accepted"
'Label1.Caption = Label1.Caption + Chr(13) + "Connection Accepted..."
Form1.Show
Form2.Hide
ws.Close
lblTr.Caption = "Closing Socket... Connecting to client."
'Label1.Caption = Label1.Caption + Chr(13) + "Closing Socket... Connecting to client."
ws.Accept requestID 'Accept the conection
'you've accepted the connection, let them know.
lblTr.Caption = "Establishing connection to remote players" & Chr(13) & "Varifying connection..."
ws.SendData ("YTAGSGAMEXOSC")
TypeMatrix "Extablishing connection..."

lblTr.Caption = "Sending Name..."
'send the name...
ws.SendData "YTPNAM" & MyTagName & "%"

lblTr.Caption = "Sending Player Color..."

'send our color
ws.SendData "%YTPCO" & MyColorNum & "%"
'varify once more..
ws.SendData "%YTCON?%"
TypeMatrix "Game Started..."

'Enable Chat and the rest of the game...
txtTransmit.Enabled = True
Paused = False
Timer1.Enabled = True
'We ARE connected now...
ConnectedtoRemote = True
Unload Form2
  CircX = 4155
  CircY = 1620
  Form1.Circle1.Left = CircX
  Form1.Circle1.Top = CircY
  OpCircX = 525
  OpCircY = 1806
  Form1.Circle2.Left = OpCircX
  Form1.Circle2.Top = OpCircY
  
Else
'we dont connect...
'if this next line makes any sort of error, comment it out
ws.SendData ("YTAGSGAMEXONC")
End If
End Sub

Private Sub ws_DataArrival(ByVal bytesTotal As Long)
Dim IData As String
Dim transi
Dim a, b, c, d, e, f, g, h, i
ws.GetData IData

'This part needs more improvement so they dont keep running out of sync...
If IData = "YTDIR1" Then 'the opponent is goin left
 OpCircDir = 1
 ElseIf IData = "YTDIR2" Then 'the opponent is goin up
 OpCircDir = 2
 ElseIf IData = "YTDIR3" Then 'the opponent is goin right
 OpCircDir = 3
 ElseIf IData = "YTDIR4" Then 'the opponent is goin down
 OpCircDir = 4
   
   ElseIf Left(IData, 5) = "%YTT%" Then
     lblTr.Caption = "Incomming Transmission..."
     transi = Right(IData, Len(IData) - 5)
     TypeMatrix OpTagName & ": " & transi
 If InStr(1, IData, "YTAGSGAMEXONC") > 0 Then MsgBox "The Host has declined your connection request... :("
 
 If InStr(1, IData, "YTAGSGAMEXOSC") > 0 Then Call HAccC 'They've Accepted our connection request
 
 If InStr(1, IData, "YTCONN") > 0 Then Call VarConD
 If InStr(1, IData, "%YTCON?%") > 0 Then Call VarCon

 If InStr(1, IData, "YTPASG") > 0 Then Call OPauseGame 'they paused the game
 If InStr(1, IData, "YTUNPS") > 0 Then Call OUnPausedGame 'they unpaused the game
 If InStr(1, IData, "YTSPNT") > 0 Then Call OpScoreP 'they scored a point
 If InStr(1, IData, "YTENDG") > 1 Then Call OEndGame 'they ended the game...
 If InStr(1, IData, "YTPNAM") > 0 Then 'we recieveed their name...
' On Error Resume Next
 a = InStr(1, IData, "YTPNAM")
 b = InStr(a, IData, "%")
 c = b - a 'calculate the length of their name...
 OpTagName = Mid(IData, (a + 6), c)
 MsgBox "Name Recieved - testinfo... name:" & OpTagName
 'they sent their color...
 End If
If InStr(1, IData, "%YTPCO1%") > 0 Then 'they're red
    OpColor = TAGColor1
    Circle2.BackColor = OpColor
End If
If InStr(1, IData, "%YTPCO2%") > 0 Then 'they're orange
    OpColor = TAGColor2
    Circle2.BackColor = OpColor
End If
If InStr(1, IData, "%YTPCO3%") > 0 Then 'they're yellow
    OpColor = TAGColor3
    Circle2.BackColor = OpColor
End If
If InStr(1, IData, "%YTPCO4%") > 0 Then 'they're green
    OpColor = TAGColor4
    Circle2.BackColor = OpColor
End If
If InStr(1, IData, "%YTPCO5%") > 0 Then 'they're red
    OpColor = TAGColor5
    Circle2.BackColor = OpColor
End If
If InStr(1, IData, "%YTPCO6%") > 0 Then 'they're blue
    OpColor = TAGColor6
    Circle2.BackColor = OpColor
End If
'shows unknown data (errors)
' lblTr.Caption = "unrecognized command: " & IData
 End If
'lblTr.Caption = IData
End Sub

Public Function RevDir(Direction As Byte) As Byte
If Direction = 1 Then RevDir = 3 'a sub to reverse the direction (when they hit a wall)
If Direction = 2 Then RevDir = 4
If Direction = 3 Then RevDir = 1
If Direction = 4 Then RevDir = 2
End Function

Public Sub TypeMatrix(Expression As String)
MatrixTextTimer.Enabled = False 'this just makes that typing effect for chat etc.
MatrixText = Expression
mlength = 0
MatrixTextTimer.Enabled = True
End Sub

Public Sub VarCon() 'connection being varified
 lblTr.Caption = ""
 TypeMatrix "Connection Varification Requested... Checking Connection..."
  ws.SendData "YTCONN"
  ConnectedtoRemote = True
  Paused = False
  Timer1.Enabled = True
End Sub

Public Sub VarConD() 'connection varified
lblTr.Caption = "Connection Varified..."
  ConnectedtoRemote = True
End Sub

Public Sub HAccC()
 Form1.MatrixTextTimer.Enabled = False
 lblTr.Caption = ""
  lblTr.Caption = "The host has ACCEPTED your connection =)"
   ws.SendData "%YTPCO" & MyColorNum & "%"
End Sub