VB封装的WebSocket模块,拿来即用

一共就下面的两个模块,调用只使用到mWSProtocol模块,所有调用函数功能简单介绍一下:

建立连接后就开始握手,服务端用Handshake()验证,如果是客户端自己发送握手封包
接收数据,先用AnalyzeHeader()得到数据帧结构(DataFrame)
然后再用PickDataV()或PickData()得到源数据进行处理
发送数据需要先进行数据帧包装:
服务端向客户端发送无需掩码,用PackString()或PackData()
而模拟客户端向服务器的发送需要加掩码,用PackMaskString()或PackMaskData()

相关资料下载：《WebSocket协议中文版.pdf》

第二次写了,完全是为了分享...如果对你有帮助就支持一下吧

mWSProtocol: 

 Option Explicit
 Option Compare Text
 '==============================================================
 'By:       悠悠然
 'QQ:       2860898817
 'E-mail:   ur1986@foxmail.com
 '完整运行示例放Q群文件共享:369088586
 '==============================================================
 Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
 Public Enum OpcodeType
     opContin =     '连续消息片断
     opText =       '文本消息片断
     opBinary =     '二进制消息片断
                     '3 - 7 非控制帧保留
     opClose =      '连接关闭
     opPing =       '心跳检查的ping
     opPong =      '心跳检查的pong
                     '11-15 控制帧保留
 End Enum
 Public Type DataFrame
     FIN As Boolean      '0表示不是当前消息的最后一帧，后面还有消息,1表示这是当前消息的最后一帧；
     RSV1 As Boolean     '1位，若没有自定义协议,必须为0,否则必须断开.
     RSV2 As Boolean     '1位，若没有自定义协议,必须为0,否则必须断开.
     RSV3 As Boolean     '1位，若没有自定义协议,必须为0,否则必须断开.
     Opcode As OpcodeType    '4位操作码，定义有效负载数据，如果收到了一个未知的操作码，连接必须断开.
     MASK As Boolean     '1位，定义传输的数据是否有加掩码,如果有掩码则存放在MaskingKey
     MaskingKey() As Byte   '32位的掩码
     Payloadlen As Long  '传输数据的长度
     DataOffset As Long  '数据源起始位
 End Type

 '==============================================================
 '握手部分,只有一个开放调用函数 Handshake(requestHeader As String) As Byte()
 '==============================================================
 Private Const MagicKey = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
 Private Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
 Public Function Handshake(requestHeader As String) As Byte()
     Dim clientKey As String
     clientKey = getHeaderValue(requestHeader, "Sec-WebSocket-Key:")
     Dim AcceptKey As String
     AcceptKey = getAcceptKey(clientKey)
     Dim response As String
     response = "HTTP/1.1 101 Web Socket Protocol Handshake" & vbCrLf
     response = response & "Upgrade: WebSocket" & vbCrLf
     response = response & "Connection: Upgrade" & vbCrLf
     response = response & "Sec-WebSocket-Accept: " & AcceptKey & vbCrLf
     response = response & "WebSocket-Origin: " & getHeaderValue(requestHeader, "Sec-WebSocket-Origin:") & vbCrLf
     response = response & "WebSocket-Location: " & getHeaderValue(requestHeader, "Host:") & vbCrLf
     response = response & vbCrLf
     'Debug.Print response
     Handshake = StrConv(response, vbFromUnicode)
 End Function
 Private Function getHeaderValue(str As String, pname As String) As String
     Dim i As Long, j As Long
     i = InStr(str, pname)
     If i >  Then
         j = InStr(i, str, vbCrLf)
         If j >  Then
             i = i + Len(pname)
             getHeaderValue = Trim(Mid(str, i, j - i))
         End If
     End If
 End Function
 Private Function getAcceptKey(key As String) As String
     Dim b() As Byte
     b = mSHA1.SHA1(StrConv(key & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11", vbFromUnicode))
     getAcceptKey = EnBase64(b)
 End Function
 Private Function EnBase64(str() As Byte) As String
     On Error GoTo over
     Dim buf() As Byte, length As Long, mods As Long
     mods = (UBound(str) + ) Mod
     length = UBound(str) +  - mods
     ReDim buf(length /  *  + IIf(mods <> , , ) - )
     Dim i As Long
     For i =  To length -  Step
         buf(i /  * ) = (str(i) And &HFC) / &H4
         buf(i /  *  + ) = (str(i) And &H3) * &H10 + (str(i + ) And &HF0) / &H10
         buf(i /  *  + ) = (str(i + ) And &HF) * &H4 + (str(i + ) And &HC0) / &H40
         buf(i /  *  + ) = str(i + ) And &H3F
     Next
     If mods =  Then
         buf(length /  * ) = (str(length) And &HFC) / &H4
         buf(length /  *  + ) = (str(length) And &H3) * &H10
         buf(length /  *  + ) =
         buf(length /  *  + ) =
     ElseIf mods =  Then
         buf(length /  * ) = (str(length) And &HFC) / &H4
         buf(length /  *  + ) = (str(length) And &H3) * &H10 + (str(length + ) And &HF0) / &H10
         buf(length /  *  + ) = (str(length + ) And &HF) * &H4
         buf(length /  *  + ) =
     End If
     For i =  To UBound(buf)
         EnBase64 = EnBase64 + Mid(B64_CHAR_DICT, buf(i) + , )
     Next
 over:
 End Function
 '==============================================================
 '数据帧解析,返回帧结构
 '==============================================================
 Public Function AnalyzeHeader(byt() As Byte) As DataFrame
     Dim DF As DataFrame
     DF.FIN = IIf((byt() And &H80) = &H80, True, False)
     DF.RSV1 = IIf((byt() And &H40) = &H40, True, False)
     DF.RSV2 = IIf((byt() And &H20) = &H20, True, False)
     DF.RSV3 = IIf((byt() And &H10) = &H10, True, False)
     DF.Opcode = byt() And &H7F
     DF.MASK = IIf((byt() And &H80) = &H80, True, False)
     Dim plen As Byte
     plen = byt() And &H7F
     If plen <  Then
         DF.Payloadlen = plen
         If DF.MASK Then
             CopyMemory DF.MaskingKey(), byt(),
             DF.DataOffset =
         Else
             DF.DataOffset =
         End If
     ElseIf plen =  Then
         Dim l() As Byte
         l() = byt()
         l() = byt()
         CopyMemory DF.Payloadlen, l(),
         If DF.MASK Then
             CopyMemory DF.MaskingKey(), byt(),
             DF.DataOffset =
         Else
             DF.DataOffset =
         End If
     ElseIf plen =  Then
         '这部分没有什么意义就不写了,因为VB没有64位的整型可供使用
         '所以对长度设定为-1,自己再判断
         DF.Payloadlen = -
         'If df.mask Then
         '    CopyMemory df.MaskingKey(0), byt(10), 4
         '    df.DataOffset = 14
         'Else
         '    df.DataOffset = 10
         'End If
     End If
     AnalyzeHeader = DF
 End Function
 '==============================================================
 '接收的数据处理,有掩码就反掩码
 'PickDataV  方法是出于性能的考虑,用于有时数据只是为了接收,做一些逻辑判断,并不需要对数据块进行单独提炼
 'PickData   不赘述了...
 '==============================================================
 Public Sub PickDataV(byt() As Byte, dataType As DataFrame)
     Dim lenLimit As Long
     lenLimit = dataType.DataOffset + dataType.Payloadlen -
     If dataType.MASK And lenLimit <= UBound(byt) Then
         Dim i As Long, j As Long
         For i = dataType.DataOffset To lenLimit
             byt(i) = byt(i) Xor dataType.MaskingKey(j)
             j = j +
             If j =  Then j =
         Next i
     End If
 End Sub
 Public Function PickData(byt() As Byte, dataType As DataFrame) As Byte()
     Dim b() As Byte
     PickDataV byt, dataType
     ReDim b(dataType.Payloadlen - )
     CopyMemory b(), byt(dataType.DataOffset), dataType.Payloadlen
     PickData = b
 End Function

 '==============================================================
 '发送的数据处理,该部分未联网测试,使用下面的方式测试验证
 'Private Sub Command1_Click()
 '    Dim str As String, b() As Byte, bs() As Byte
 '    Dim DF As DataFrame
 '    str = "abc123"
 '    Showlog "组装前数据:" & str
 '    b = mWSProtocol.PackMaskString(str):    Showlog "掩码后字节:" & BytesToHex(b)
 '    DF = mWSProtocol.AnalyzeHeader(b):      Showlog "结构体偏移:" & DF.DataOffset & "  长度:" & DF.Payloadlen
 '    bs = mWSProtocol.PickData(b, DF):       Showlog "还原后字节:" & BytesToHex(bs)
 '    Showlog "还原后数据:" & StrConv(bs, vbUnicode)
 'End Sub
 '==============================================================
 '无掩码数据的组装,用于服务端向客户端发送
 '--------------------------------------------------------------
 Public Function PackString(str As String, Optional dwOpcode As OpcodeType = opText) As Byte()
     Dim b() As Byte
     b = StrConv(str, vbFromUnicode)
     PackString = PackData(b, dwOpcode)
 End Function
 Public Function PackData(data() As Byte, Optional dwOpcode As OpcodeType = opText) As Byte()
     Dim length As Long
     Dim byt() As Byte
     length = UBound(data) + 

     If length <  Then
         ReDim byt(length + )
         byt() = CByte(length)
         CopyMemory byt(), data(), length
     ElseIf length <=  Then
         ReDim byt(length + )
         Dim l() As Byte
         byt() = &H7E
         CopyMemory l(), length,
         byt() = l()
         byt() = l()
         CopyMemory byt(), data(), length
     'ElseIf length <= 999999999999999# Then
         '这么长不处理了...
         'VB6也没有这么大的整型
         '有需要就根据上面调整来写吧
     End If
     '------------------------------
     '关于下面的 byt(0) = &H80 Or dwOpcode 中，&H80 对应的是 DataFrame 结构中的FIN + RSV1 + RSV2 + RSV3
     'FIN 的中文解释是：指示这个是消息的最后片段，第一个片段可能也是最后的片段。
     '这里我不是很理解，可能是自定义分包用到吧，但貌似分包应该不是自己可控的，所以我默认是 1。
     '------------------------------
     byt() = &H80 Or dwOpcode
     PackData = byt
 End Function
 '--------------------------------------------------------------
 '有掩码数据的组装,用于替代客户端想服务端发送
 '--------------------------------------------------------------
 Public Function PackMaskString(str As String) As Byte()
     Dim b() As Byte
     b = StrConv(str, vbFromUnicode)
     PackMaskString = PackMaskData(b)
 End Function
 Public Function PackMaskData(data() As Byte) As Byte()
     '对源数据做掩码处理
     Dim mKey() As Byte
     mKey() = : mKey() = : mKey() = : mKey() =  '掩码,你也可以自己定义
     Dim i As Long, j As Long
     For i =  To UBound(data)
         data(i) = data(i) Xor mKey(j)
         j = j +
         If j =  Then j =
     Next i
     '包装,和上面的无掩码包装PackData()大体相同
     Dim length As Long
     Dim byt() As Byte
     length = UBound(data) +
     If length <  Then
         ReDim byt(length + )
         byt() = &H81 '注意这里是按照OpcodeType里面的文本类型,其他类型,比如字节包应该是 byt(0) = &h80 or OpcodeType.opBinary
         byt() = (CByte(length) Or &H80)
         CopyMemory byt(), mKey(),
         CopyMemory byt(), data(), length
     ElseIf length <=  Then
         ReDim byt(length + )
         Dim l() As Byte
         byt() = &H81 '同上注意
         byt() = &HFE '固定 掩码位+126
         CopyMemory l(), length,
         byt() = l()
         byt() = l()
         CopyMemory byt(), mKey(),
         CopyMemory byt(), data(), length
     'ElseIf length <= 999999999999999# Then
         '这么长不处理了...有需要就根据上面调整来写吧
     End If
     PackMaskData = byt
 End Function
 '==============================================================
 '控制帧相关,Ping、Pong、Close 用于服务端向客户端发送未经掩码的信号
 '我用的0长度,其实是可以包含数据的,但是附带数据客户端处理又麻烦了
 '
 '* 如果有附带信息的需求,也可以用PackString或PackData,可选参数指定OpcodeType
 '==============================================================
 Public Function PingFrame() As Byte()
     Dim b() As Byte
     b() = &H89
     b() = &H0
     PingFrame = b
     '发送一个包含"Hello"的Ping信号: 0x89 0x05 0x48 0x65 0x6c 0x6c 0x6f
 End Function
 Public Function PongFrame() As Byte()
     Dim b() As Byte
     b() = &H8A
     b() = &H0
     PongFrame = b
     '发送一个包含"Hello"的Pong信号: 0x8A 0x05 0x48 0x65 0x6c 0x6c 0x6f
 End Function
 Public Function CloseFrame() As Byte()
     Dim b() As Byte
     b() = &H88
     b() = &H0
     CloseFrame = b
     '发送一个包含"Close"的Pong信号: 0x8A 0x05 0x43 0x6c 0x6f 0x73 0x65
 End Function

mSHA1: 

 Option Explicit
 '==============================================================
 '该模块来自网络资料,进行了小改动,源作者不详
 '==============================================================
 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
 Private Type Word
     B0 As Byte
     B1 As Byte
     B2 As Byte
     B3 As Byte
 End Type
 Private Function AndW(w1 As Word, w2 As Word) As Word
     AndW.B0 = w1.B0 And w2.B0
     AndW.B1 = w1.B1 And w2.B1
     AndW.B2 = w1.B2 And w2.B2
     AndW.B3 = w1.B3 And w2.B3
 End Function

 Private Function OrW(w1 As Word, w2 As Word) As Word
     OrW.B0 = w1.B0 Or w2.B0
     OrW.B1 = w1.B1 Or w2.B1
     OrW.B2 = w1.B2 Or w2.B2
     OrW.B3 = w1.B3 Or w2.B3
 End Function

 Private Function XorW(w1 As Word, w2 As Word) As Word
     XorW.B0 = w1.B0 Xor w2.B0
     XorW.B1 = w1.B1 Xor w2.B1
     XorW.B2 = w1.B2 Xor w2.B2
     XorW.B3 = w1.B3 Xor w2.B3
 End Function

 Private Function NotW(w As Word) As Word
     NotW.B0 = Not w.B0
     NotW.B1 = Not w.B1
     NotW.B2 = Not w.B2
     NotW.B3 = Not w.B3
 End Function

 Private Function AddW(w1 As Word, w2 As Word) As Word
     Dim i As Long, w As Word
     i = CLng(w1.B3) + w2.B3
     w.B3 = i Mod
     i = CLng(w1.B2) + w2.B2 + (i \ )
     w.B2 = i Mod
     i = CLng(w1.B1) + w2.B1 + (i \ )
     w.B1 = i Mod
     i = CLng(w1.B0) + w2.B0 + (i \ )
     w.B0 = i Mod
     AddW = w
 End Function

 Private Function CircShiftLeftW(w As Word, n As Long) As Word
     Dim d1 As Double, d2 As Double
     d1 = WordToDouble(w)
     d2 = d1
     d1 = d1 * ( ^ n)
     d2 = d2 / ( ^ ( - n))
     CircShiftLeftW = OrW(DoubleToWord(d1), DoubleToWord(d2))
 End Function

 Private Function WordToHex(w As Word) As String
     WordToHex = Right$("" & Hex$(w.B0), ) & Right$("" & Hex$(w.B1), ) & Right$("" & Hex$(w.B2), ) & Right$("" & Hex$(w.B3), )
 End Function

 Private Function HexToWord(H As String) As Word
     HexToWord = DoubleToWord(Val("&H" & H & "#"))
 End Function

 Private Function DoubleToWord(n As Double) As Word
     DoubleToWord.B0 = Int(DMod(n,  ^ ) / ( ^ ))
     DoubleToWord.B1 = Int(DMod(n,  ^ ) / ( ^ ))
     DoubleToWord.B2 = Int(DMod(n,  ^ ) / ( ^ ))
     DoubleToWord.B3 = Int(DMod(n,  ^ ))
 End Function

 Private Function WordToDouble(w As Word) As Double
     WordToDouble = (w.B0 * ( ^ )) + (w.B1 * ( ^ )) + (w.B2 * ( ^ )) + w.B3
 End Function

 Private Function DMod(value As Double, divisor As Double) As Double
     DMod = value - (Int(value / divisor) * divisor)
     If DMod <  Then DMod = DMod + divisor
 End Function

 Private Function F(t As Long, b As Word, C As Word, D As Word) As Word
     Select Case t
         Case Is <=
             F = OrW(AndW(b, C), AndW(NotW(b), D))
         Case Is <=
             F = XorW(XorW(b, C), D)
         Case Is <=
             F = OrW(OrW(AndW(b, C), AndW(b, D)), AndW(C, D))
         Case Else
             F = XorW(XorW(b, C), D)
     End Select
 End Function
 Public Function StringSHA1(inMessage As String) As String
     ' 计算字符串的SHA1摘要
     Dim inLen As Long
     Dim inLenW As Word
     Dim padMessage As String
     Dim numBlocks As Long
     Dim w( To ) As Word
     Dim blockText As String
     Dim wordText As String
     Dim i As Long, t As Long
     Dim temp As Word
     Dim k( To ) As Word
     Dim H0 As Word
     Dim H1 As Word
     Dim H2 As Word
     Dim H3 As Word
     Dim H4 As Word
     Dim A As Word
     Dim b As Word
     Dim C As Word
     Dim D As Word
     Dim E As Word
     inMessage = StrConv(inMessage, vbFromUnicode)
     inLen = LenB(inMessage)
     inLenW = DoubleToWord(CDbl(inLen) * )
     padMessage = inMessage & ChrB() _
     & StrConv(String(( - (inLen Mod ) - ) Mod  + , Chr()), ) _
     & ChrB(inLenW.B0) & ChrB(inLenW.B1) & ChrB(inLenW.B2) & ChrB(inLenW.B3)
     numBlocks = LenB(padMessage) /
     k() = HexToWord("5A827999")
     k() = HexToWord("6ED9EBA1")
     k() = HexToWord("8F1BBCDC")
     k() = HexToWord("CA62C1D6")
     H0 = HexToWord("")
     H1 = HexToWord("EFCDAB89")
     H2 = HexToWord("98BADCFE")
     H3 = HexToWord("")
     H4 = HexToWord("C3D2E1F0")
     For i =  To numBlocks -
         blockText = MidB$(padMessage, (i * ) + , )
         For t =  To
             wordText = MidB$(blockText, (t * ) + , )
             w(t).B0 = AscB(MidB$(wordText, , ))
             w(t).B1 = AscB(MidB$(wordText, , ))
             w(t).B2 = AscB(MidB$(wordText, , ))
             w(t).B3 = AscB(MidB$(wordText, , ))
         Next
         For t =  To
             w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - ), w(t - )), w(t - )), w(t - )), )
         Next
         A = H0
         b = H1
         C = H2
         D = H3
         E = H4
         For t =  To
             temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, ), _
             F(t, b, C, D)), E), w(t)), k(t \ ))
             E = D
             D = C
             C = CircShiftLeftW(b, )
             b = A
             A = temp
         Next
         H0 = AddW(H0, A)
         H1 = AddW(H1, b)
         H2 = AddW(H2, C)
         H3 = AddW(H3, D)
         H4 = AddW(H4, E)
     Next
     StringSHA1 = WordToHex(H0) & WordToHex(H1) & WordToHex(H2) & WordToHex(H3) & WordToHex(H4)
 End Function
 '计算字节数组的SHA1摘要
 Public Function SHA1(inMessage() As Byte) As Byte()
     Dim inLen As Long
     Dim inLenW As Word
     Dim numBlocks As Long
     Dim w( To ) As Word
     Dim blockText As String
     Dim wordText As String
     Dim t As Long
     Dim temp As Word
     Dim k( To ) As Word
     Dim H0 As Word
     Dim H1 As Word
     Dim H2 As Word
     Dim H3 As Word
     Dim H4 As Word
     Dim A As Word
     Dim b As Word
     Dim C As Word
     Dim D As Word
     Dim E As Word
     Dim i As Long
     Dim lngPos As Long
     Dim lngPadMessageLen As Long
     Dim padMessage() As Byte
     inLen = UBound(inMessage) +
     inLenW = DoubleToWord(CDbl(inLen) * )
     lngPadMessageLen = inLen +  + ( - (inLen Mod ) - ) Mod  +
     ReDim padMessage(lngPadMessageLen - ) As Byte
     For i =  To inLen -
         padMessage(i) = inMessage(i)
     Next i
     padMessage(inLen) =
     padMessage(lngPadMessageLen - ) = inLenW.B0
     padMessage(lngPadMessageLen - ) = inLenW.B1
     padMessage(lngPadMessageLen - ) = inLenW.B2
     padMessage(lngPadMessageLen - ) = inLenW.B3
     numBlocks = lngPadMessageLen /
     k() = HexToWord("5A827999")
     k() = HexToWord("6ED9EBA1")
     k() = HexToWord("8F1BBCDC")
     k() = HexToWord("CA62C1D6")
     H0 = HexToWord("")
     H1 = HexToWord("EFCDAB89")
     H2 = HexToWord("98BADCFE")
     H3 = HexToWord("")
     H4 = HexToWord("C3D2E1F0")
     For i =  To numBlocks -
         For t =  To
             w(t).B0 = padMessage(lngPos)
             w(t).B1 = padMessage(lngPos + )
             w(t).B2 = padMessage(lngPos + )
             w(t).B3 = padMessage(lngPos + )
             lngPos = lngPos +
         Next
         For t =  To
             w(t) = CircShiftLeftW(XorW(XorW(XorW(w(t - ), w(t - )), w(t - )), w(t - )), )
         Next
         A = H0
         b = H1
         C = H2
         D = H3
         E = H4
         For t =  To
             temp = AddW(AddW(AddW(AddW(CircShiftLeftW(A, ), _
             F(t, b, C, D)), E), w(t)), k(t \ ))
             E = D
             D = C
             C = CircShiftLeftW(b, )
             b = A
             A = temp
         Next
         H0 = AddW(H0, A)
         H1 = AddW(H1, b)
         H2 = AddW(H2, C)
         H3 = AddW(H3, D)
         H4 = AddW(H4, E)
     Next
     Dim byt() As Byte
     CopyMemory byt(), H0,
     CopyMemory byt(), H1,
     CopyMemory byt(), H2,
     CopyMemory byt(), H3,
     CopyMemory byt(), H4,
     SHA1 = byt
 End Function