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","发送登陆请求"
#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 ">>>","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,"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 = 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","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,MK_NOMARK,"8888") '发送关闭消息
End If
End If
End Select
'-----------------------------------------------------------------------
Exit Sub
ErrHandle:
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) = 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,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,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",Err.description
End Sub