本示例使用设备介绍:WIFI无线4G网络RFID云读卡器远程网络开关物流网阅读器TTS语音-淘宝网 (taobao.com)
Option Explicit
Const BUSY As Boolean = False '定义常量
Const FREE As Boolean = True
Dim 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 Sub
Private Sub Command1_Click()
initsock
End Sub
Private Sub Command10_Click()
Dim copstr As String
Dim i As Long
Clipboard.Clear
copstr = ""
For i = 0 To List2.ListCount
copstr = copstr & List2.List(i)
copstr = copstr & vbCrLf
Next
Clipboard.SetText (copstr)
MsgBox "TCP通讯报文列表已拷贝!", vbInformation + vbOKOnly, "提示"
End Sub
Private Sub Command2_Click()
GetSendData 5
ButtonSend
End Sub
Private Sub Command3_Click()
Dim i As Integer
Dim sockid As Integer
Dim dispinf As String
On Error Resume Next
For i = List1.ListCount - 1 To 0 Step -1 '要用倒序
If List1.Selected(i) = True Then
sockid = Val(Mid(List1.List(i), 1, 2))
Sock(sockid).Close
ConnectState(sockid) = FREE
dispinf = Format(Now, "HH:MM:SS") & " 连接 " & sockid & " 已关闭"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
List1.RemoveItem i
End If
Next
End Sub
Private Sub Command4_Click()
GetSendData 0
ButtonSend
End Sub
Private Sub Command5_Click()
GetSendData 1
ButtonSend
End Sub
Private Sub Command6_Click()
GetSendData 2
ButtonSend
End Sub
Private Sub Command7_Click()
GetSendData 3
ButtonSend
End Sub
Private Sub Command8_Click()
GetSendData 4
ButtonSend
End Sub
Private Sub Command9_Click()
List2.Clear
End Sub
Private Sub Form_Load()
Dim i As Integer
For i = 1 To 255
Combo9.AddItem (Format(i, "0"))
Next
Combo9.ListIndex = 19
Combo2.ListIndex = 1
Combo3.ListIndex = 0
Combo8.ListIndex = 1
Command1_Click
End Sub
Private Sub Listener_Close()
'MsgBox "close"
Dim dispinf As String
dispinf = Format(Now, "HH:MM:SS") & " 监听服务已关闭!"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End Sub
Private Sub Listener_ConnectionRequest(ByVal requestID As Long)
Dim SockIndex As Integer
Dim SockNum As Integer
Dim dispinf As String
Dim onlines As String
On Error Resume Next
dispinf = Format(Now, "HH:MM:SS") & " " & requestID & "连接请求"
SockNum = UBound(ConnectState) '查找连接的用户数
If SockNum > 100 Then
dispinf = dispinf & SockIndex & " ,当前连接数>100,系统不接受新连接!"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
Exit Sub
End If
SockIndex = FindFreeSocket() '查找空闲的sock
If SockIndex > SockNum Then '如果已有的sock都忙,而且sock数不超过15个,动态添加sock
Load 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.RemotePort
List1.AddItem (onlines)
List1.ListIndex = List1.ListCount - 1
List1.Selected(List1.ListCount - 1) = True
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End Sub
Private 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 Sub
Private Sub Sock_Close(Index As Integer)
Dim dispinf As String
Dim i As Integer
If Sock(Index).State <> sckClosed Then
Sock(Index).Close
End If
ConnectState(Index) = FREE
dispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 已关闭"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
For i = 0 To List1.ListCount - 1
If Val(Mid(List1.List(i), 1, 2)) = Index Then
List1.RemoveItem i
Exit For
End If
Next
End Sub
Private 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 String
Sock(Index).GetData TcpData
IPort = Sock(Index).RemoteHostIP & ":" & Sock(Index).RemotePort
For i = 0 To bytesTotal - 1
dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2) + " "
Next
dispinf = Format(Now, "HH:MM:SS") & " FromIP " & IPort & " :" & dispstr
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
Select Case TcpData(0)
Case &HC1, &HCF
If TcpData(0) = &HC1 Then
dispstr = "数据解析:接收到IC卡刷卡数据,读卡器IP["
Else
dispstr = "数据解析:接收到IC卡离开读卡器,读卡器IP["
End If
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 + "],卡号长度[" + Trim(Str(TcpData(9)))
dispstr = dispstr + "],16进制卡号["
For i = 10 To 9 + TcpData(9)
dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)
Next
doublecardhao = TcpData(13)
doublecardhao = doublecardhao * 256
doublecardhao = doublecardhao + TcpData(12)
doublecardhao = doublecardhao * 256
doublecardhao = doublecardhao + TcpData(11)
doublecardhao = doublecardhao * 256
doublecardhao = doublecardhao + TcpData(10)
card10str = Right("0000000000" + CStr(doublecardhao), 10)
dispstr = dispstr + "],转10进制卡号[" + card10str
dispstr = dispstr + "],唯一硬件序号["
For i = 10 + TcpData(9) To bytesTotal - 1
dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)
Next
dispstr = dispstr + "]"
List2.AddItem (dispstr)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1
If Check1.Value > 0 Then Response Index, IPort
Case &HD1, &HDF
If TcpData(0) = &HD1 Then
dispstr = "数据解析:接收到ID卡刷卡数据,读卡器IP["
Else
dispstr = "数据解析:接收到ID卡离开读卡器,读卡器IP["
End If
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")
doublecardhao = TcpData(12)
doublecardhao = doublecardhao * 256
doublecardhao = doublecardhao + TcpData(11)
doublecardhao = doublecardhao * 256
doublecardhao = doublecardhao + TcpData(10)
doublecardhao = doublecardhao * 256
doublecardhao = 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进制卡号[" + card10str
dispstr = dispstr + "],唯一硬件序号["
For i = 14 To bytesTotal - 1
dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)
Next
dispstr = dispstr + "]"
List2.AddItem (dispstr)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1
If Check1.Value > 0 Then Response Index, IPort
Case &HF3
dispstr = "数据解析:接收到读卡器心跳包,读卡器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 - 1
dispstr = dispstr + Right("00" + Hex(TcpData(i)), 2)
Next
dispstr = dispstr + "]"
List2.AddItem (dispstr)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1
End Select
End Sub
Public Function FindFreeSocket() '寻找空闲的sock
Dim SockCount, i As Integer
SockCount = UBound(ConnectState)
For i = 0 To SockCount
If ConnectState(i) = FREE Then
FindFreeSocket = i
Exit Function
End If
Next i
ReDim Preserve ConnectState(0 To SockCount + 1)
FindFreeSocket = UBound(ConnectState)
End Function
Private Sub initsock()
Dim dispinf As String
ReDim Preserve ConnectState(0 To 1)
On Error GoTo err1
ConnectState(0) = FREE
ConnectState(1) = FREE
If Listener.State = sckClosed Then
Listener.LocalPort = CLng(Text1.Text) '指定网络端口号
Listener.Listen '开始侦听
dispinf = Format(Now, "HH:MM:SS") & " 已创建监听服务!可以接收客户端的连接请求。"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
Command1.Caption = "关闭监听服务"
Else
Listener.Close
dispinf = Format(Now, "HH:MM:SS") & " 已关闭监听服务!不再接受新的客户端连接请求,已连接的客户端还可以通讯。"
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
Command1.Caption = "创建监听服务"
End If
Exit Sub
err1:
dispinf = Format(Now, "HH:MM:SS") & " 开启监听服务时出现错误:" & Err.Number & Err.Description
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
End Sub
Private 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 Integer
If Sock(Index).State <> sckClosed Then
Sock(Index).Close
End If
ConnectState(Index) = FREE
dispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 错误提示:" & Description
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
For i = 0 To List1.ListCount - 1
If Val(Mid(List1.List(i), 1, 2)) = Index Then
List1.RemoveItem i
Exit For
End If
Next
End Sub
Private Sub Text5_Click()
Shell Environ("PROGRAMFILES") & "\Internet Explorer\iexplore.exe " & Trim(Text5)
End Sub
Private Sub Response(Index As Integer, IPort As String)
On Error GoTo err1
If Check1.Value > 0 Then
If Option1(0) Then
GetSendData 0
ElseIf Option1(1) Then
GetSendData 1
ElseIf Option1(2) Then
GetSendData 2
Else
GetSendData 3
End If
End If
Dim dispinf As String
Dim sendstr As String
Dim i As Integer
On Error GoTo err1
For i = 0 To UBound(ServerSendbuf)
sendstr = sendstr + Right("00" + Hex(ServerSendbuf(i)), 2) + " "
Next
Sock(Index).SendData ServerSendbuf
dispinf = Format(Now, "HH:MM:SS") & " SendTo " & IPort & " :" & sendstr
List2.AddItem (dispinf)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1
Exit Sub
err1:
dispinf = Format(Now, "HH:MM:SS") & " 连接 " & Index & " 传送数据时出错:" & Err.Description
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
List1.RemoveItem i
End Sub
Private 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 String
On Error GoTo err1
For i = 0 To UBound(ServerSendbuf)
sendstr = sendstr + Right("00" + Hex(ServerSendbuf(i)), 2) + " "
Next
For i = 0 To List1.ListCount - 1
If List1.Selected(i) = True Then
sockid = Val(Mid(List1.List(i), 1, 2))
Sock(sockid).SendData ServerSendbuf
dataArray = Split(List1.List(i), "|")
IPort = dataArray(2)
dispinf = Format(Now, "HH:MM:SS") & " SendTo " & IPort & " :" & sendstr
List2.AddItem (dispinf)
List2.AddItem ("")
List2.ListIndex = List2.ListCount - 1
End If
Next
Exit Sub
err1:
dispinf = Format(Now, "HH:MM:SS") & " 连接 " & sockid & " 传送数据时出错:" & Err.Description
List2.AddItem (dispinf)
List2.ListIndex = List2.ListCount - 1
List1.RemoveItem i
End Sub
Private 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 Byte
Select Case responseid
Case 0 '生成显示文字发送数据缓冲
ReDim ServerSendbuf(38)
ServerSendbuf(0) = &H5A '命令字,表示驱动蜂鸣器声响
ServerSendbuf(1) = 0
ServerSendbuf(2) = 0
If Check2.Value = 1 Then
ServerSendbuf(3) = Combo2.ListIndex '声音类型
If Option12.Value = True Then
ServerSendbuf(3) = ServerSendbuf(3) Or 128
End If
Else
ServerSendbuf(3) = &HFF '不发音
If Option12.Value = True Then
ServerSendbuf(3) = ServerSendbuf(3) And 127
End If
End If
ServerSendbuf(4) = Combo9.ListIndex '20 '显示保留时间,单位为秒,为255时表示永久显示
strls = Text7.Text + " "
textbyte = StrConv(strls, vbFromUnicode) '字符串转换为字节数组
For i = 0 To 33
ServerSendbuf(i + 5) = textbyte(i)
Next
Case 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) + 1
displen = 34 '双行屏34,四行屏72
sendbyte = 11 + displen + lensy + 4
ReDim ServerSendbuf(sendbyte)
ServerSendbuf(0) = &H5C '命令字,表示驱动TTS合成语音\显示及继电器
ServerSendbuf(1) = 0
ServerSendbuf(2) = 0
If Check2.Value = 1 Then
ServerSendbuf(3) = Combo2.ListIndex '声音类型
If Option12.Value = True Then
ServerSendbuf(3) = ServerSendbuf(3) Or 128
End If
Else
ServerSendbuf(3) = &HFF '不发音
If Option12.Value = True Then
ServerSendbuf(3) = ServerSendbuf(3) And 127
End If
End If
Select Case Combo3.ListIndex
Case 1
ServerSendbuf(4) = &HF1
Case 2
ServerSendbuf(4) = &HF2
Case 3
ServerSendbuf(4) = &HF3
Case 4
ServerSendbuf(4) = &HF4
Case 5
ServerSendbuf(4) = &HF5
Case 6
ServerSendbuf(4) = &HF6
Case 7
ServerSendbuf(4) = &HF7
Case 8
ServerSendbuf(4) = &HF8
Case Else
ServerSendbuf(4) = &HF0
End Select
'时长
i = Val(Trim(Text30.Text))
ServerSendbuf(5) = i Mod 256
ServerSendbuf(6) = Int(i / 256) Mod 256
ServerSendbuf(7) = Combo9.ListIndex '20 '显示保留时间,单位为秒,为255时表示永久显示
ServerSendbuf(8) = 0 '在显示屏中的哪个位置开始
ServerSendbuf(9) = displen '显示字符串长度 0-34为全屏
strls = Text7.Text + " "
Dim a() As Byte
a = StrConv(strls, vbFromUnicode) '字符串转换为字节数组
For i = 1 To displen '显示文字的ASCII码
ServerSendbuf(i + 10) = a(i - 1)
Next
ServerSendbuf(10) = lensy '语音长度,最长可为126
For i = 1 To lensy 'TTS语音的ASCII码
ServerSendbuf(i + 10 + displen) = textbyte(i - 1)
Next
ServerSendbuf(10 + ServerSendbuf(9) + lensy + 1) = &H55
ServerSendbuf(10 + ServerSendbuf(9) + lensy + 2) = &HAA
ServerSendbuf(10 + ServerSendbuf(9) + lensy + 3) = &H66
ServerSendbuf(10 + ServerSendbuf(9) + lensy + 4) = &H99
Case 2 '生成蜂鸣响声发送数据缓冲
ReDim ServerSendbuf(3)
ServerSendbuf(0) = &H96 '命令字,表示驱动蜂鸣器声响
ServerSendbuf(1) = 0 'Tcp通讯,机号00表示任意机器
ServerSendbuf(2) = 0
ServerSendbuf(3) = Combo2.ListIndex '声音类型
Case 3 '生成继电器开关发送数据缓冲
ReDim ServerSendbuf(5)
ServerSendbuf(0) = &H78 '命令字,表示驱动蜂鸣器声响
ServerSendbuf(1) = 0 'Tcp通讯,机号00表示任意机器
ServerSendbuf(2) = 0
Select Case Combo3.ListIndex
Case 1
ServerSendbuf(3) = &HF1
Case 2
ServerSendbuf(3) = &HF2
Case 3
ServerSendbuf(3) = &HF3
Case 4
ServerSendbuf(3) = &HF4
Case 5
ServerSendbuf(3) = &HF5
Case 6
ServerSendbuf(3) = &HF6
Case 7
ServerSendbuf(3) = &HF7
Case 8
ServerSendbuf(3) = &HF8
Case Else
ServerSendbuf(3) = &HF0
End Select
i = Val(Trim(Text30.Text)) '时长
ServerSendbuf(4) = i Mod 256
ServerSendbuf(5) = Int(i / 256) Mod 256
Case 4 '生成继电器开关发送数据缓冲
ReDim ServerSendbuf(5)
ServerSendbuf(0) = &H78 '命令字,表示驱动蜂鸣器声响
ServerSendbuf(1) = 0 'Tcp通讯,机号00表示任意机器
ServerSendbuf(2) = 0
Select Case Combo3.ListIndex
Case 1
ServerSendbuf(3) = &HE1
Case 2
ServerSendbuf(3) = &HE2
Case 3
ServerSendbuf(3) = &HE3
Case 4
ServerSendbuf(3) = &HE4
Case 5
ServerSendbuf(3) = &HE5
Case 6
ServerSendbuf(3) = &HE6
Case 7
ServerSendbuf(3) = &HE7
Case 8
ServerSendbuf(3) = &HE8
Case Else
ServerSendbuf(3) = &HE0
End Select
i = Val(Trim(Text30.Text)) '时长
ServerSendbuf(4) = i Mod 256
ServerSendbuf(5) = Int(i / 256) Mod 256
Case 5 '生成重发刷卡数据发送数据缓冲
ReDim ServerSendbuf(2)
ServerSendbuf(0) = &HA7 '命令字:重新获取刷卡信息
ServerSendbuf(1) = 0 'Tcp通讯,机号00表示任意机器
ServerSendbuf(2) = 0
End Select
End Sub