websocket vb

概述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 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 SubPublic 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 SubPublic 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 = RvEnd 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","发送登陆请求"      #End If      Else         iClIEnt.disconnect      End If   End SubPrivate 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 SubPrivate 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 ">>>","lLogin = " & lLogin & " / " & strS               #End If                             Call ProcWebSocketkeyvalue(strS)  '处理key值                        End If         End If                  End If112   CSCount = CHAO_SHI '通讯超时计数         '-----------------------------------------------------------------------      Exit SubErrHandle:113   IDeBUGErr "iClIEnt_OnRead",Erl,Err.Number,Err.description      '-----------------------------------------------------------------------End SubPrivate Sub iClIEnt_OnTimer()      If lLogin = 1 Then     '//连接成功      Call Me.SenDWebPackDataFromStr(WM_TEXT,"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,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,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 = 0End 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","lLogin = " & lLogin & " / " & DR & " / " & _                             Len(DR)      #End If102   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 = 3108               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 = 2115            bWebsocket = True            Else               Call Me.SenDWebPackDataFromStr(WM_CLOSE,MK_NOMARK,"8888") '发送关闭消息            End If         End If            End Select      '-----------------------------------------------------------------------      Exit SubErrHandle:118   IDeBUGErr "ProcWebSocketkeyvalue",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,0) '掩码值 用于异或加密数据101   For Q = 0 To UBound(HD)102      HD(Q) = 0103   Next Q  104   If Fin <> 0 Then HD(0) = HD(0) Or &H80 '帧标记0,1105   If Rsv >= 1 And Rsv <= 7 Then '扩展协议标记0-7106      b = Rsv * 16107      HD(0) = HD(0) Or b      End If108   If Opcode > 0 And Opcode <= 15 Then ' *** 作码(消息类型)0-15109      HD(0) = HD(0) Or Opcode      End If  110   HLen = 2: PLen = ln111   If MarkCode <> 0 Then '有掩码112      HD(1) = HD(1) Or &H80      End If113   If ln <= 125 Then '7BIT114      b = ln Mod 126115      HD(1) = HD(1) Or b116   ElseIf ln >= 126 And ln <= 65535 Then '16BIT117      HD(1) = HD(1) Or &H7E '126118      PLen = PLen + 2119      HD(2) = (ln \ 256&) Mod 256 '(PLen \ 256&) Mod 256120      HD(3) = ln Mod 256 'PLen Mod 256121      HLen = HLen + 2      Else 'bit64122      HD(1) = HD(1) Or &H7F '127123      PLen = PLen + 8124      HD(2) = 0125      HD(3) = 0126      HD(4) = 0127      HD(5) = 0         'Call Me.LongToByteRev(PLen,HD,6)128      Call Me.LongToByteRev(ln,6)129      HLen = HLen + 8      End If  130   PLen = ln + HLen131   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 If137   If ln > 0 Then138      If MarkCode <> 0 Then '异或加密数据139         For Q = 0 To ln - 1140            RetSD(HLen + Q) = Bd(Addr + Q) Xor MK(Q Mod 4)141         Next Q         Else142         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 = -1End 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,cmd)  '发送数据    End Sub

SenDWinsockData

Public Sub SenDWinsockData(SD() As Byte,ByVal ln As Long) '发送数据    On Error GoTo ErrHandle   iClIEnt.Write SD(),ln      Exit SubErrHandle:114   IDeBUGErr "SenDWinsockData",Err.descriptionEnd Sub

总结

以上是内存溢出为你收集整理的websocket vb全部内容，希望文章能够帮你解决websocket vb所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。