websocket vb

最新推荐文章于 2022-10-19 19:32:20 发布

q123456789098

最新推荐文章于 2022-10-19 19:32:20 发布

阅读量3.7k

点赞数 1

本文链接：https://blog.csdn.net/q123456789098/article/details/49531571

版权

WinX.iServerIP = "61.234.170.173"
   WinX.iServerPort = 3000
   WinX.iServerRequestURL = "http://61.234.170.173/index.php"

   Dim bOK As Boolean, PostData As String
rrr:
         bOK = frmMain.HttpRequest("name=Java&password=200199", PostData, "?module=user&action=login", True)

Public Function HttpRequest(ByVal PostData As Variant, _name=Java&password=200199
                            ByRef returnMsg As String, _PostData
                            Optional ByVal sRequestURL As String = "", _?module=user&action=login
                            Optional ByVal GetCookie As Boolean = False, _True
                            Optional sContentType As String = "application/x-www-form-urlencoded", _
                            Optional sHost As String = "") As Boolean

      On Error GoTo ErrHandle

      DoEvents

100   If Len(sRequestURL) = 0 Then
101      sRequestURL = WinX.iServerRequestURL
      Else
         '//http://
102      If Left$(sRequestURL, 1) = "?" Then
103         sRequestURL = WinX.iServerRequestURL & sRequestURL
         End If
      End If

      Dim xmlobject As Object

106   Set xmlobject = CreateObject("winhttp.winhttprequest.5.1")
      Call xmlobject.setTimeouts(15000, 15000, 30000, 30000)

108   xmlobject.open "POST", sRequestURL, True

113   xmlobject.setRequestHeader "Content-Type", sContentType

116   If Not GetCookie Then
117      If Len(iUser.Cookie) > 0 Then xmlobject.setRequestHeader "Cookie", iUser.Cookie
      End If

118   xmlobject.send PostData

119   Call xmlobject.waitForResponse

120   If xmlobject.Status = 200 Then

132      returnMsg = xmlobject.responseText
         MsgBox returnMsg


139      If GetCookie Then
            Dim Cookie As String
140         Cookie = xmlobject.getResponseHeader("Set-Cookie")

141         iUser.Cookie = Mid$(Cookie, 1, InStr(Cookie, ";") - 1)
             MsgBox iUser.Cookie
         End If

ByteArrayToHexStr

Public Function ByteArrayToHexStr(RD() As Byte, ByVal Idx&, ByVal ln As Long) As String
  Dim VR As String
  Dim Q As Long
  
  VR = ""
  For Q = 0 To ln - 1
    If RD(Idx + Q) < 16 Then
      VR = VR + "0" + Hex(RD(Idx + Q))
    Else
      VR = VR + Hex(RD(Idx + Q))
    End If
  Next Q
  ByteArrayToHexStr = VR
  
End Function

ByteToLongRev LongToByteRev Get9RandNumber

Public Sub ByteToLongRev(Sour() As Byte, ByVal Idx As Long, Des As Long)
   
   Dim Nr$
   Nr = "&H" + Hex(Sour(Idx))
   If Sour(Idx + 1) < 16 Then Nr = Nr + "0" + Hex(Sour(Idx + 1)) Else Nr = Nr + Hex(Sour(Idx + 1))
   If Sour(Idx + 2) < 16 Then Nr = Nr + "0" + Hex(Sour(Idx + 2)) Else Nr = Nr + Hex(Sour(Idx + 2))
   If Sour(Idx + 3) < 16 Then Nr = Nr + "0" + Hex(Sour(Idx + 3)) Else Nr = Nr + Hex(Sour(Idx + 3))
   Nr = Nr + "&"
   Des = Val(Nr)
  
End Sub
Public Sub LongToByteRev(ByVal Sour As Long, Des() As Byte, ByVal Idx As Long)
   
   Dim Nr$, k%
   Nr = Hex(Sour)
   k = Len(Nr)
   If k < 8 Then Nr = String(8 - k, "0")
   Des(Idx) = Val("&H" + Mid(Nr, 1, 2))
   Des(Idx + 1) = Val("&H" + Mid(Nr, 3, 2))
   Des(Idx + 2) = Val("&H" + Mid(Nr, 5, 2))
   Des(Idx + 3) = Val("&H" + Mid(Nr, 7, 2))
  
End Sub

Public Function Get9RandNumber(ByVal WS%) As Long '得到指定位数随机数
   Dim Rv&, i%
   Dim W(10) As Byte
  
   Do
      For i = 0 To 8
         If i = 0 Then W(i) = Int(1 + 9 * Rnd) Else W(i) = Int(10 * Rnd)
      Next i
      Rv = 0
      For i = 0 To WS - 1
         Rv = Rv + 10 ^ (WS - i - 1) * W(i)
      Next i
      If WS = 3 Then
         If Rv <= 255& Then Exit Do
      ElseIf WS = 5 Then
         If Rv <= 65535 Then Exit Do
      Else
         If Rv <= 999999999 Then Exit Do
      End If
   Loop While (1)
   Get9RandNumber = Rv
End Function

iClient_OnConnect iClient_OnDisconnect iClient_OnError

Private Sub iClient_OnConnect()
   
   If frmMain.Socket_OnConnect Then
   
      Dim DR As String
      CSCount = CHAO_SHI
      lLogin = 2
      WinX.Server_Connected = True
      WinX.Server_ConnectStatus = 1
      Call SendRequestWebData(USER_URL) '发送登陆请求
      
      #If iCCC Then
      iDebugErr "iClient_OnConnect", "0", "0", "发送登陆请求"
      #End If
   
   Else
   
      iClient.Disconnect
   
   End If
   
End Sub

Private Sub iClient_OnDisconnect()
   
   If WinX.Server_Connected Then frmMain.Socket_OnDisconnect
         
   lLogin = 0
   iClient.Interval = 0
   WinX.Server_Connected = False
   WinX.Server_ConnectStatus = -1
   
   '//TimerNet.Enabled = False
        
End Sub

Private Sub iClient_OnError(ByVal ErrorCode As Variant, ByVal description As Variant)
   
   frmMain.Socket_OnError ErrorCode, description
   iClient_OnDisconnect
   
End Sub

iClient_OnRead iClient_OnTimer

Private Sub iClient_OnRead()

      On Error GoTo ErrHandle

      Dim bytB() As Byte, ln As Long, strS As String
      
100   ln = iClient.Read(bytB, 80000)

102   If ln > 0 Then
         
         If lLogin = 1 Then
            CBS.AddData bytB
            Do While CBS.GetMsg(bytB)
               strS = Utf8ToUnicode(bytB)
               Select Case strS
               Case "2::"
                  '//'//iDebugInfo "接收到心跳包"
                  Call Me.SendWebPackDataFromStr(WM_TEXT, PAG_BIT7, MK_RANDMARK, "2:::")
               Case "0::"
                  frmMain.Socket_OnDisconnect True
               Case Else
                  frmMain.Socket_OnMessage strS
               End Select
            Loop
         Else
            strS = StrConv(bytB, vbUnicode)
            If Len(strS) > 0 Then
            
               #If iCCC Then
               iDebugErr ">>>", "0", "0", "lLogin = " & lLogin & " / " & strS
               #End If
               
              Call ProcWebSocketKeyValue(strS)  '处理key值
            
            End If
         End If
            
      End If

112   CSCount = CHAO_SHI '通讯超时计数
   
      '-----------------------------------------------------------------------
      Exit Sub
ErrHandle:
113   iDebugErr "iClient_OnRead", Erl, Err.Number, Err.description
      '-----------------------------------------------------------------------

End Sub

Private Sub iClient_OnTimer()
   
   If lLogin = 1 Then     '//连接成功
      Call Me.SendWebPackDataFromStr(WM_TEXT, PAG_BIT7, MK_RANDMARK, "2:::")
      '//'//iDebugInfo "发送心跳包 > " & Now
   End If
      
End Sub

SendWinsockDataFromStr

Public Sub SendWinsockDataFromStr(ByVal SR As String) '发送数据
  
   Dim SD() As Byte, ln As Long
   If Len(SR) = 0 Then Exit Sub
   SD = StrConv(SR, vbFromUnicode)
   ln = UBound(SD) + 1
   Call Me.SendWinsockData(SD, ln)
  
End Sub

SendWebPackDataFromStr

Public Sub SendWebPackDataFromStr(ByVal MsgType As WEBMSGTYPE, ByVal pageSize As PAGESIZETYPE, ByVal MarkCode As MARKCODETYPE, ByVal SR As String) '发送数据
  Dim Bd() As Byte, ln As Long, MK As Long
  Dim Block As Long
  Dim Q As Long, BS As Long
  Dim SD() As Byte
  Dim Fin As Byte
  Dim Rsv As Byte
  Dim Opcode As WEBMSGTYPE
  Dim lS As Long, k As Long, Rn As Long
  
  Bd = StrConv(SR, vbFromUnicode)
  ln = UBound(Bd) + 1
  Block = ln: MK = 0
  If pageSize = PAG_BIT7 Then
    Block = 125
  ElseIf pageSize = PAG_BIT16 Then
    Block = 65535
  ElseIf pageSize = PAG_BIT32 Then
    Block = ln
  End If
  If MsgType = WM_CLOSE Or MsgType = WM_PING Or MsgType = WM_PONG Then '是控制帧消息不分页
    Block = ln
  End If
  
  Q = ln Mod Block
  If Q = 0 Then BS = ln \ Block Else BS = ln \ Block + 1
  
  Rsv = 0: lS = 0
  For Q = 1 To BS '分包发送
    If MarkCode = MK_RANDMARK Then MK = Me.Get9RandNumber(9)
    If (lS + Block) > ln Then k = ln - lS Else k = Block
    If BS = 1 Then '不分页
      Fin = 1
      Opcode = MsgType
      Rn = Me.BuidWebSocketPacket(Fin, Rsv, Opcode, MK, Bd, lS, k, SD) '获取包
      If Rn > 0 Then Call Me.SendWinsockData(SD, Rn) '发送
    ElseIf BS >= 2 Then '分页
      If Q = 1 Then '第一包 opcode<>0
        Fin = 0
        If MsgType = WM_NEXT Then Opcode = WM_TEXT Else Opcode = MsgType
      ElseIf Q = BS Then '最后一包
        Fin = 1
        Opcode = WM_NEXT
      Else '中间包
        Fin = 0
        Opcode = WM_NEXT
      End If
      Rn = Me.BuidWebSocketPacket(Fin, Rsv, Opcode, MK, Bd, lS, k, SD) '获取包
      If Rn > 0 Then Call Me.SendWinsockData(SD, Rn) '发送
    End If
    lS = lS + k
  Next Q
  
End Sub

CloseClient

Public Sub CloseClient()         '//关闭客户端
   TimerNet.Enabled = False
   If WinX.Server_Connected Then iClient.Disconnect
   lLogin = 0
End Sub

SendlLoginWebData

Public Sub SendlLoginWebData(ByVal url As String, ByVal cKey As String) '发送握手数据

   Dim data As String
   data = "GET /socket.io/1/websocket/" & cKey & " HTTP/1.1" & vbCrLf
   data = data & "Host: " & url & vbCrLf
   data = data & "Upgrade: WebSocket" & vbCrLf
   data = data & "Connection: Upgrade" & vbCrLf
   data = data & "Sec-WebSocket-Key: " & cKey & vbCrLf  '  这个key要换成随机的
   data = data & "Sec-WebSocket-Version: 13" & vbCrLf
   '//data = data & "Cookie: " & iUser.Cookie & vbCrLf
   data = data & "Origin: *" & vbCrLf & vbCrLf
  
   Call Me.SendWinsockDataFromStr(data)
  
End Sub

SendRequestWebData

Public Sub SendRequestWebData(ByVal url As String) '发送登陆请求

   Dim data As String
   
   Dim iver
   iver = App.Major & "." & App.Minor & "." & Format$(App.Revision, "0000")
   
   data = "GET /socket.io/1/?t=" & DateDiff("s", "01/01/1970 00:00:00", Now()) & "&client=inkever&version=" & iver & " HTTP/1.1" & _
                       vbCrLf
   data = data & "Host: " & url & vbCrLf
    
   data = data & "Connection: keep-alive" & vbCrLf
   data = data & "Accept: */*" & vbCrLf
   data = data & "Accept-Language: zh-CN,zh;q=0.8" & vbCrLf
   data = data & "Accept-Charset: GBK,utf-8;q=0.7,*;q=0.3" & vbCrLf
   data = data & "Cookie: " & iUser.Cookie & vbCrLf & vbCrLf
    
   Debug.Print '----------------------------------------------------------------------------
   Debug.Print "SendRequestWebData", data
   Debug.Print '----------------------------------------------------------------------------
    
   Call Me.SendWinsockDataFromStr(data)
    
End Sub

ProcWebSocketKeyValue

Public Sub ProcWebSocketKeyValue(ByVal DR As String) '处理key值

      On Error GoTo ErrHandle

      Dim Vn()  As String, LR As String
      Dim Q     As Integer, k As Integer
      Dim Bd(1) As Byte
  
100   Vn = Split(DR, vbCrLf)
101   Q = UBound(Vn)

      #If iCCC Then
         iDebugErr "ProcWebSocketKeyValue", "0", "0", "lLogin = " & lLogin & " / " & DR & " / " & _
                             Len(DR)
      #End If

102   Select Case lLogin
      Case 2
      
         If InStr(DR, "500 Internal Server Error") Or InStr(DR, "handshake error") Then
            
               WinX.Server_Connected = False
               WinX.Server_ConnectStatus = -2
            
         Else
         
            '//iDebugInfo DR
            
            Dim ii As Long
            For ii = 0 To Q
               If InStr(Vn(ii), ":websocket") Then
                  Vn = Split(Vn(ii), ":")
111               lLogin = 3
108               Call SendlLoginWebData(USER_URL, Vn(0))     '//发送握手数据
109               CHAO_SHI = Val(Vn(1)) * 20& '心跳包周期计数
110               If CHAO_SHI < 300 Then CHAO_SHI = 300
                  Exit For
               End If
            Next

'103         If Q > 3 Then
'104            LR = Vn(Q - 3)
'105            Vn = Split(LR, ":")
'106            Q = UBound(Vn)
'107            If Q >= 1 Then
'111               lLogin = 3
'108               Call SendlLoginWebData(USER_URL, Vn(0))     '//发送握手数据
'109               CHAO_SHI = Val(Vn(1)) * 20& '心跳包周期计数
'110               If CHAO_SHI < 300 Then CHAO_SHI = 300
'               End If
'            End If
         
         End If
      
112   Case 3
                     
         Debug.Print "lLogin = 3"
   
113      If Right$(Vn(Q), 3) = "1::" Then '握手成功
114         lLogin = 1
            iClient.Interval = 10000
            If frmMain.Socket_OnWebSocket Then     'And (Not WinX.ifrmMain)
               WinX.Server_ConnectStatus = 2
115            bWebsocket = True
            Else
               Call Me.SendWebPackDataFromStr(WM_CLOSE, PAG_BIT7, MK_NOMARK, "8888") '发送关闭消息
            End If
         End If
      
      End Select

      '-----------------------------------------------------------------------
      Exit Sub
ErrHandle:
118   iDebugErr "ProcWebSocketKeyValue", Erl, Err.Number, Err.description
      '-----------------------------------------------------------------------
  
End Sub

BuidWebSocketPacket

Public Function BuidWebSocketPacket(ByVal Fin As Byte, _
                                    ByVal Rsv As Byte, _
                                    ByVal Opcode As Byte, _
                                    ByVal MarkCode As Long, _
                                    Bd() As Byte, _
                                    ByVal Addr As Long, _
                                    ByVal ln As Long, _
                                    RetSD() As Byte) As Long 'WebSocket打包
      Dim HD(10) As Byte, b As Byte
      Dim Q      As Long
      Dim MK(4)  As Byte
      Dim HLen   As Long
      Dim PLen   As Long
  
      '数据格式: 标记2+[消息长度2,8]+[掩码4]+数据n
      '帧头2字节
      '1.BIT7:      结束标记     0=后面还有数据 1=结束帧
      '1.BIT6-BIT4: 扩展定义标记 0=无扩展
      '1.BIT3-BIT0: 消息类型
      '2.BIT7:      掩码标记     0=无掩码 1=后面紧跟掩码字节
      '2.BIT6-BIT0: 消息长度     <=125 数据实际字节 126=数据字节(126--65535) 127=数据字节(65536-40亿)
  
100   Call Me.LongToByteRev(MarkCode, MK, 0) '掩码值 用于异或加密数据
101   For Q = 0 To UBound(HD)
102      HD(Q) = 0
103   Next Q
  
104   If Fin <> 0 Then HD(0) = HD(0) Or &H80 '帧标记0,1
105   If Rsv >= 1 And Rsv <= 7 Then '扩展协议标记0-7
106      b = Rsv * 16
107      HD(0) = HD(0) Or b
      End If
108   If Opcode > 0 And Opcode <= 15 Then '操作码(消息类型)0-15
109      HD(0) = HD(0) Or Opcode
      End If
  
110   HLen = 2: PLen = ln
111   If MarkCode <> 0 Then '有掩码
112      HD(1) = HD(1) Or &H80
      End If
113   If ln <= 125 Then '7BIT
114      b = ln Mod 126
115      HD(1) = HD(1) Or b
116   ElseIf ln >= 126 And ln <= 65535 Then '16BIT
117      HD(1) = HD(1) Or &H7E '126
118      PLen = PLen + 2
119      HD(2) = (ln \ 256&) Mod 256 '(PLen \ 256&) Mod 256
120      HD(3) = ln Mod 256 'PLen Mod 256
121      HLen = HLen + 2
      Else 'BIT64
122      HD(1) = HD(1) Or &H7F '127
123      PLen = PLen + 8
124      HD(2) = 0
125      HD(3) = 0
126      HD(4) = 0
127      HD(5) = 0
         'Call Me.LongToByteRev(PLen, HD, 6)
128      Call Me.LongToByteRev(ln, HD, 6)
129      HLen = HLen + 8
      End If
  
130   PLen = ln + HLen
131   If MarkCode <> 0 Then PLen = PLen + 4 '有掩码
132   ReDim RetSD(PLen - 1)
  
133   Call CopyMemory(RetSD(0), HD(0), HLen) '帧头字节
134   If MarkCode <> 0 Then '有掩码
135      Call CopyMemory(RetSD(HLen), MK(0), 4) '掩码4字节 数据长度字节不包含掩码4字节
136      HLen = HLen + 4
      End If
137   If ln > 0 Then
138      If MarkCode <> 0 Then '异或加密数据
139         For Q = 0 To ln - 1
140            RetSD(HLen + Q) = Bd(Addr + Q) Xor MK(Q Mod 4)
141         Next Q
         Else
142         Call CopyMemory(RetSD(HLen), Bd(Addr), ln) '用户数据
         End If
      End If
  
143   BuidWebSocketPacket = PLen
 
End Function

CloseWebConnect

Public Sub CloseWebConnect() '关闭连接
   
   lLogin = 0
   If WinX.Server_Connected Then
      frmMain.Socket_OnDisconnect
   End If
   TimerNet.Enabled = False
   WinX.Server_Connected = False
   WinX.Server_ConnectStatus = -1

End Sub

sendEvent

Public Sub sendEvent(ByVal eventName As String, ByVal Args As String)
    
    Dim cmd As String
    cmd = "5:::{'name':'" & eventName & "','args':" & Args & "}"
    cmd = Replace$(cmd, "'", Chr$(34))
    
    Debug.Print "cmd>" & cmd
    
    '//iDebugInfo "发送指令 = " & cmd
    If lLogin = 1 Then Call frmSocket.SendWebPackDataFromStr(WM_TEXT, PAG_BIT32, MK_NOMARK, cmd)  '发送数据
    
End Sub

SendWinsockData

Public Sub SendWinsockData(SD() As Byte, ByVal ln As Long) '发送数据

    On Error GoTo ErrHandle


   iClient.Write SD(), ln

      Exit Sub
ErrHandle:
114   iDebugErr "SendWinsockData", Erl, Err.Number, Err.description

End Sub

q123456789098

关注

1
点赞
踩
4

收藏

觉得还不错? 一键收藏
1
评论
websocket vb

ByteArrayToHexStrPublic Function ByteArrayToHexStr(RD() As Byte, ByVal Idx&, ByVal ln As Long) As String Dim VR As String Dim Q As Long VR = "" For Q = 0 To ln - 1 If RD(Idx + Q) <
复制链接

扫一扫