本示例使用设备介绍：WIFI无线4G网络RFID云读卡器远程网络开关物流网阅读器TTS语音-淘宝网 (taobao.com) 

Option ExplicitConst BUSY As Boolean = False    '定义常量
Const FREE As Boolean = TrueDim ConnectState() As Boolean   '定义连接状态
Dim ServerSendbuf() As Byte     '数据发送缓冲Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Check1.Value > 0 Then Frame1.Visible = True Else Frame1.Visible = False
End SubPrivate Sub Command1_Click()
initsock
End SubPrivate Sub Command10_Click()
Dim copstr As String
Dim i As Long
Clipboard.Clear
copstr = ""
For i = 0 To List2.ListCountcopstr = copstr & List2.List(i)copstr = copstr & vbCrLf
NextClipboard.SetText (copstr)
MsgBox "TCP通讯报文列表已拷贝！", vbInformation + vbOKOnly, "提示"
End SubPrivate Sub Command2_Click()
GetSendData 5
ButtonSend
End SubPrivate Sub Command3_Click()
Dim i As Integer
Dim sockid As Integer
Dim dispinf As StringOn Error Resume NextFor i = List1.ListCount - 1 To 0 Step -1   '要用倒序If List1.Selected(i) = True Thensockid = Val(Mid(List1.List(i), 1, 2))Sock(sockid).CloseConnectState(sockid) = FREEdispinf = Format(Now, "HH:MM:SS") & " 连接 " & sockid & " 已关闭"List2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1List1.RemoveItem iEnd If
Next
End SubPrivate Sub Command4_Click()
GetSendData 0
ButtonSend
End SubPrivate Sub Command5_Click()
GetSendData 1
ButtonSendEnd SubPrivate Sub Command6_Click()
GetSendData 2
ButtonSend
End SubPrivate Sub Command7_Click()
GetSendData 3
ButtonSend
End SubPrivate Sub Command8_Click()
GetSendData 4
ButtonSend
End SubPrivate Sub Command9_Click()
List2.Clear
End SubPrivate Sub Form_Load()
Dim i As IntegerFor i = 1 To 255Combo9.AddItem (Format(i, "0"))
Next
Combo9.ListIndex = 19
Combo2.ListIndex = 1
Combo3.ListIndex = 0
Combo8.ListIndex = 1Command1_Click
End SubPrivate Sub Listener_Close()
'MsgBox "close"
Dim dispinf As String
dispinf = Format(Now, "HH:MM:SS") & " 监听服务已关闭！"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End SubPrivate Sub Listener_ConnectionRequest(ByVal requestID As Long)
Dim SockIndex As Integer
Dim SockNum As Integer
Dim dispinf As String
Dim onlines As StringOn Error Resume Nextdispinf = Format(Now, "HH:MM:SS") & " " & requestID & "连接请求"SockNum = UBound(ConnectState)   '查找连接的用户数
If SockNum > 100 Thendispinf = dispinf & SockIndex & " ，当前连接数>100，系统不接受新连接！"List2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1Exit Sub
End IfSockIndex = FindFreeSocket()   '查找空闲的sockIf SockIndex > SockNum Then    '如果已有的sock都忙，而且sock数不超过15个，动态添加sockLoad Sock(SockIndex)
End If
ConnectState(SockIndex) = BUSY
Sock(SockIndex).LocalPort = 0
Sock(SockIndex).Tag = SockIndex
Sock(SockIndex).Accept (requestID)  '接受请求onlines = Format(SockIndex, "00") & "|" & Format(requestID, "00000") & "|" & Listener.RemoteHostIP & ":" & Listener.RemotePort
dispinf = dispinf & SockIndex & "接受请求，" & Listener.RemoteHostIP & ":" & Listener.RemotePortList1.AddItem (onlines)
List1.ListIndex = List1.ListCount - 1
List1.Selected(List1.ListCount - 1) = TrueList2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End SubPrivate Sub Listener_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
'MsgBox "err"
Dim dispinf As String
dispinf = Format(Now, "HH:MM:SS") & " 监听到异常错误！"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End SubPrivate Sub Sock_Close(Index As Integer)
Dim dispinf As String
Dim i As IntegerIf Sock(Index).State <> sckClosed ThenSock(Index).Close
End If
ConnectState(Index) = FREEdispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 已关闭"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1For i = 0 To List1.ListCount - 1If Val(Mid(List1.List(i), 1, 2)) = Index ThenList1.RemoveItem iExit ForEnd If
Next
End SubPrivate Sub Sock_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim dx As String
Dim dispinf As String
Dim dispstr As String
Dim i As Integer
Dim TcpData() As Byte
Dim IPort As String
Dim doublecardhao  As Double
Dim card10str As StringSock(Index).GetData TcpData
IPort = Sock(Index).RemoteHostIP & ":" & Sock(Index).RemotePortFor i = 0 To bytesTotal - 1dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2) + " "
Next
dispinf = Format(Now, "HH:MM:SS") & " FromIP " & IPort & " ：" & dispstr
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1Select Case TcpData(0)Case &HC1, &HCFIf TcpData(0) = &HC1 Thendispstr = "数据解析：接收到IC卡刷卡数据，读卡器IP["Elsedispstr = "数据解析：接收到IC卡离开读卡器，读卡器IP["End Ifdispstr = dispstr + Trim(Str(TcpData(1))) + "." + Trim(Str(TcpData(2))) + "." + Trim(Str(TcpData(3))) + "." + Trim(Str(TcpData(4)))dispstr = dispstr + "],机号["'机号dispstr = dispstr + Format(Str$(CLng(TcpData(5)) + CLng(TcpData(6)) * 256), "00000")dispstr = dispstr + "],数据包序号["'数据包序号，每个包都不一样，按递增1变化dispstr = dispstr + Format(Str$(CLng(TcpData(7)) + CLng(TcpData(8)) * 256), "00000")dispstr = dispstr + "],卡号长度[" + Trim(Str(TcpData(9)))dispstr = dispstr + "],16进制卡号["For i = 10 To 9 + TcpData(9)dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)Nextdoublecardhao = TcpData(13)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(12)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(11)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(10)card10str = Right("0000000000" + CStr(doublecardhao), 10)dispstr = dispstr + "],转10进制卡号[" + card10strdispstr = dispstr + "],唯一硬件序号["For i = 10 + TcpData(9) To bytesTotal - 1dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)Nextdispstr = dispstr + "]"List2.AddItem (dispstr)List2.AddItem ("")List2.ListIndex = List2.ListCount - 1If Check1.Value > 0 Then Response Index, IPortCase &HD1, &HDFIf TcpData(0) = &HD1 Thendispstr = "数据解析：接收到ID卡刷卡数据，读卡器IP["Elsedispstr = "数据解析：接收到ID卡离开读卡器，读卡器IP["End Ifdispstr = dispstr + Trim(Str(TcpData(1))) + "." + Trim(Str(TcpData(2))) + "." + Trim(Str(TcpData(3))) + "." + Trim(Str(TcpData(4)))dispstr = dispstr + "],机号["'机号dispstr = dispstr + Format(Str$(CLng(TcpData(5)) + CLng(TcpData(6)) * 256), "00000")dispstr = dispstr + "],数据包序号["'数据包序号，每个包都不一样，按递增1变化dispstr = dispstr + Format(Str$(CLng(TcpData(7)) + CLng(TcpData(8)) * 256), "00000")doublecardhao = TcpData(12)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(11)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(10)doublecardhao = doublecardhao * 256doublecardhao = doublecardhao + TcpData(9)card10str = Right("0000000000" + CStr(doublecardhao), 10)dispstr = dispstr + "],16进制卡号["dispstr = dispstr + Right("00" + Hex(TcpData(9)), 2) + Right("00" + Hex(TcpData(10)), 2) + Right("00" + Hex(TcpData(11)), 2) + Right("00" + Hex(TcpData(12)), 2) + Right("00" + Hex(TcpData(13)), 2) + "],转10进制卡号[" + card10strdispstr = dispstr + "],唯一硬件序号["For i = 14 To bytesTotal - 1dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)Nextdispstr = dispstr + "]"List2.AddItem (dispstr)List2.AddItem ("")List2.ListIndex = List2.ListCount - 1If Check1.Value > 0 Then Response Index, IPortCase &HF3dispstr = "数据解析：接收到读卡器心跳包，读卡器IP["dispstr = dispstr + Trim(Str(TcpData(1))) + "." + Trim(Str(TcpData(2))) + "." + Trim(Str(TcpData(3))) + "." + Trim(Str(TcpData(4)))dispstr = dispstr + "],机号["'机号dispstr = dispstr + Format(Str$(CLng(TcpData(5)) + CLng(TcpData(6)) * 256), "00000")dispstr = dispstr + "],数据包序号["'数据包序号，每个包都不一样，按递增1变化dispstr = dispstr + Format(Str$(CLng(TcpData(7)) + CLng(TcpData(8)) * 256), "00000") + "],"dispstr = dispstr + "心跳包类型[" + Right("00" + Hex(TcpData(9)), 2) + "],"dispstr = dispstr + "长度[" + Right("00" + Hex(TcpData(10)), 2) + "],"dispstr = dispstr + "继电器状态[" + Right("00" + Hex(TcpData(11)), 2) + "],"dispstr = dispstr + "外部输入状态[" + Right("00" + Hex(TcpData(12)), 2) + "],"dispstr = dispstr + "随机动态码[" + Right("00" + Hex(TcpData(13)), 2) + Right("00" + Hex(TcpData(14)), 2) + Right("00" + Hex(TcpData(15)), 2) + Right("00" + Hex(TcpData(16)), 2) + "],"dispstr = dispstr + "唯一硬件序号["For i = 17 To bytesTotal - 1dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)Nextdispstr = dispstr + "]"List2.AddItem (dispstr)List2.AddItem ("")List2.ListIndex = List2.ListCount - 1
End Select
End SubPublic Function FindFreeSocket()   '寻找空闲的sock
Dim SockCount, i As Integer
SockCount = UBound(ConnectState)
For i = 0 To SockCountIf ConnectState(i) = FREE ThenFindFreeSocket = iExit FunctionEnd If
Next iReDim Preserve ConnectState(0 To SockCount + 1)
FindFreeSocket = UBound(ConnectState)
End FunctionPrivate Sub initsock()
Dim dispinf As String
ReDim Preserve ConnectState(0 To 1)
On Error GoTo err1ConnectState(0) = FREE
ConnectState(1) = FREEIf Listener.State = sckClosed ThenListener.LocalPort = CLng(Text1.Text)    '指定网络端口号Listener.Listen                          '开始侦听dispinf = Format(Now, "HH:MM:SS") & " 已创建监听服务！可以接收客户端的连接请求。"List2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1Command1.Caption = "关闭监听服务"
ElseListener.Closedispinf = Format(Now, "HH:MM:SS") & " 已关闭监听服务！不再接受新的客户端连接请求，已连接的客户端还可以通讯。"List2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1Command1.Caption = "创建监听服务"
End IfExit Suberr1:dispinf = Format(Now, "HH:MM:SS") & " 开启监听服务时出现错误：" & Err.Number & Err.DescriptionList2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1
End SubPrivate Sub Sock_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Dim dispinf As String
Dim i As IntegerIf Sock(Index).State <> sckClosed ThenSock(Index).Close
End If
ConnectState(Index) = FREEdispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 错误提示：" & Description
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1For i = 0 To List1.ListCount - 1If Val(Mid(List1.List(i), 1, 2)) = Index ThenList1.RemoveItem iExit ForEnd If
Next
End SubPrivate Sub Text5_Click()
Shell Environ("PROGRAMFILES") & "\Internet Explorer\iexplore.exe  " & Trim(Text5)
End SubPrivate Sub Response(Index As Integer, IPort As String)
On Error GoTo err1If Check1.Value > 0 ThenIf Option1(0) ThenGetSendData 0ElseIf Option1(1) ThenGetSendData 1ElseIf Option1(2) ThenGetSendData 2ElseGetSendData 3End If
End IfDim dispinf As String
Dim sendstr As String
Dim i As IntegerOn Error GoTo err1For i = 0 To UBound(ServerSendbuf)sendstr = sendstr + Right("00" + Hex(ServerSendbuf(i)), 2) + " "
NextSock(Index).SendData ServerSendbufdispinf = Format(Now, "HH:MM:SS") & " SendTo " & IPort & " ：" & sendstr
List2.AddItem (dispinf)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1Exit Suberr1:dispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 传送数据时出错：" & Err.DescriptionList2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1List1.RemoveItem iEnd SubPrivate Sub ButtonSend()
Dim dataArray() As String
Dim sendstr As String
Dim IPort As String
Dim i As Integer
Dim sockid As Integer
Dim dispinf As StringOn Error GoTo err1For i = 0 To UBound(ServerSendbuf)sendstr = sendstr + Right("00" + Hex(ServerSendbuf(i)), 2) + " "
NextFor i = 0 To List1.ListCount - 1If List1.Selected(i) = True Thensockid = Val(Mid(List1.List(i), 1, 2))Sock(sockid).SendData ServerSendbufdataArray = Split(List1.List(i), "|")IPort = dataArray(2)dispinf = Format(Now, "HH:MM:SS") & " SendTo " & IPort & " ：" & sendstrList2.AddItem (dispinf)List2.AddItem ("")List2.ListIndex = List2.ListCount - 1End If
Next
Exit Suberr1:dispinf = Format(Now, "HH:MM:SS") & " 连接 " & sockid & " 传送数据时出错：" & Err.DescriptionList2.AddItem (dispinf)List2.ListIndex = List2.ListCount - 1List1.RemoveItem iEnd SubPrivate Sub GetSendData(responseid As Integer)    '生成服务器发送缓冲数据
Dim i, J As Integer
Dim longi As Long
Dim dispinf As String
Dim strls As String
Dim lensy, displen, sendbyte As Integer
Dim textbyte() As ByteSelect Case responseidCase 0                      '生成显示文字发送数据缓冲ReDim ServerSendbuf(38)ServerSendbuf(0) = &H5A '命令字，表示驱动蜂鸣器声响ServerSendbuf(1) = 0ServerSendbuf(2) = 0If Check2.Value = 1 ThenServerSendbuf(3) = Combo2.ListIndex '声音类型If Option12.Value = True ThenServerSendbuf(3) = ServerSendbuf(3) Or 128End IfElseServerSendbuf(3) = &HFF '不发音If Option12.Value = True ThenServerSendbuf(3) = ServerSendbuf(3) And 127End IfEnd IfServerSendbuf(4) = Combo9.ListIndex  '20 '显示保留时间，单位为秒，为255时表示永久显示strls = Text7.Text + "                                         "textbyte = StrConv(strls, vbFromUnicode)      '字符串转换为字节数组For i = 0 To 33ServerSendbuf(i + 5) = textbyte(i)NextCase 1              '生成显示文字+蜂鸣响声+继电器+TTS语音发送数据缓冲strls = "[v"If (Combo8.ListIndex <= 16) Then strls = strls & Format(Combo8.ListIndex, "0") & "]" Else strls = strls & "16]"     '在需要发送的语音字符串中任何位置加入[v10],表示将音量调到10级(范围0~16，0表示静音，16最大，每次重开机后，音量重置为10级)！strls = strls & Trim(Text3.Text)textbyte = StrConv(strls, vbFromUnicode)      '字符串转换为字节数组lensy = UBound(textbyte) + 1displen = 34   '双行屏34，四行屏72sendbyte = 11 + displen + lensy + 4ReDim ServerSendbuf(sendbyte)ServerSendbuf(0) = &H5C    '命令字，表示驱动TTS合成语音\显示及继电器ServerSendbuf(1) = 0ServerSendbuf(2) = 0If Check2.Value = 1 ThenServerSendbuf(3) = Combo2.ListIndex '声音类型If Option12.Value = True ThenServerSendbuf(3) = ServerSendbuf(3) Or 128End IfElseServerSendbuf(3) = &HFF '不发音If Option12.Value = True ThenServerSendbuf(3) = ServerSendbuf(3) And 127End IfEnd IfSelect Case Combo3.ListIndexCase 1ServerSendbuf(4) = &HF1Case 2ServerSendbuf(4) = &HF2Case 3ServerSendbuf(4) = &HF3Case 4ServerSendbuf(4) = &HF4Case 5ServerSendbuf(4) = &HF5Case 6ServerSendbuf(4) = &HF6Case 7ServerSendbuf(4) = &HF7Case 8ServerSendbuf(4) = &HF8Case ElseServerSendbuf(4) = &HF0End Select'时长i = Val(Trim(Text30.Text))ServerSendbuf(5) = i Mod 256ServerSendbuf(6) = Int(i / 256) Mod 256ServerSendbuf(7) = Combo9.ListIndex  '20 '显示保留时间，单位为秒，为255时表示永久显示ServerSendbuf(8) = 0 '在显示屏中的哪个位置开始ServerSendbuf(9) = displen '显示字符串长度 0-34为全屏strls = Text7.Text + "                                         "Dim a() As Bytea = StrConv(strls, vbFromUnicode)      '字符串转换为字节数组For i = 1 To displen                        '显示文字的ASCII码ServerSendbuf(i + 10) = a(i - 1)NextServerSendbuf(10) = lensy                    '语音长度，最长可为126For i = 1 To lensy                     'TTS语音的ASCII码ServerSendbuf(i + 10 + displen) = textbyte(i - 1)NextServerSendbuf(10 + ServerSendbuf(9) + lensy + 1) = &H55ServerSendbuf(10 + ServerSendbuf(9) + lensy + 2) = &HAAServerSendbuf(10 + ServerSendbuf(9) + lensy + 3) = &H66ServerSendbuf(10 + ServerSendbuf(9) + lensy + 4) = &H99Case 2      '生成蜂鸣响声发送数据缓冲ReDim ServerSendbuf(3)ServerSendbuf(0) = &H96 '命令字，表示驱动蜂鸣器声响ServerSendbuf(1) = 0    'Tcp通讯，机号00表示任意机器ServerSendbuf(2) = 0ServerSendbuf(3) = Combo2.ListIndex  '声音类型Case 3       '生成继电器开关发送数据缓冲ReDim ServerSendbuf(5)ServerSendbuf(0) = &H78 '命令字，表示驱动蜂鸣器声响ServerSendbuf(1) = 0    'Tcp通讯，机号00表示任意机器ServerSendbuf(2) = 0Select Case Combo3.ListIndexCase 1ServerSendbuf(3) = &HF1Case 2ServerSendbuf(3) = &HF2Case 3ServerSendbuf(3) = &HF3Case 4ServerSendbuf(3) = &HF4Case 5ServerSendbuf(3) = &HF5Case 6ServerSendbuf(3) = &HF6Case 7ServerSendbuf(3) = &HF7Case 8ServerSendbuf(3) = &HF8Case ElseServerSendbuf(3) = &HF0End Selecti = Val(Trim(Text30.Text))  '时长ServerSendbuf(4) = i Mod 256ServerSendbuf(5) = Int(i / 256) Mod 256Case 4       '生成继电器开关发送数据缓冲ReDim ServerSendbuf(5)ServerSendbuf(0) = &H78 '命令字，表示驱动蜂鸣器声响ServerSendbuf(1) = 0    'Tcp通讯，机号00表示任意机器ServerSendbuf(2) = 0Select Case Combo3.ListIndexCase 1ServerSendbuf(3) = &HE1Case 2ServerSendbuf(3) = &HE2Case 3ServerSendbuf(3) = &HE3Case 4ServerSendbuf(3) = &HE4Case 5ServerSendbuf(3) = &HE5Case 6ServerSendbuf(3) = &HE6Case 7ServerSendbuf(3) = &HE7Case 8ServerSendbuf(3) = &HE8Case ElseServerSendbuf(3) = &HE0End Selecti = Val(Trim(Text30.Text))  '时长ServerSendbuf(4) = i Mod 256ServerSendbuf(5) = Int(i / 256) Mod 256Case 5      '生成重发刷卡数据发送数据缓冲ReDim ServerSendbuf(2)ServerSendbuf(0) = &HA7  '命令字：重新获取刷卡信息ServerSendbuf(1) = 0    'Tcp通讯，机号00表示任意机器ServerSendbuf(2) = 0End SelectEnd Sub