Vb6 Modbus TCP通讯示例源代码

MODBUS TCP读卡器介绍：https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.13.2a205b43dVtabq&id=601009585329https://item.taobao.com/item.htm?spm=a1z10.5-c.w4002-17663462238.13.2a205b43dVtabq&id=601009585329 

Private Sub Command1_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr, writstr As String
Dim I, J As Integer

If Val(Text44) > 255 Then
    MsgBox "最大站号：255 ！请重新输入有效站号。", vbCritical + vbOKOnly, "提示"
    Text44.SetFocus
    Exit Sub
End If

If Val(Text45) > 255 Then
    MsgBox "最大站号：255 ！请重新输入有效站号。", vbCritical + vbOKOnly, "提示"
    Text45.SetFocus
    Exit Sub
End If

writstr = Trim(Text10.Text)
If writstr <> "" Then writstr = writstr + " "
writstr = writstr + "00 00"

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &HB
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H6
sendbuf(8) = &H0
sendbuf(9) = Val(Text7)
sendbuf(10) = "&H" + Mid(writstr, 1, 2)
sendbuf(11) = "&H" + Mid(writstr, 1, 2)
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command10_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H7
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H6
sendbuf(8) = &H0
sendbuf(9) = &H7
sendbuf(10) = &H0
sendbuf(11) = &H8
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command11_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H8
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H3
sendbuf(8) = &H0
sendbuf(9) = Val(Text7)
sendbuf(10) = &H0
sendbuf(11) = Val(Text8)
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
Text10 = ""
End Sub

Private Sub Command13_Click()
Dim sendbuf() As Byte
Dim bytes(0 To 100) As Byte
Dim sendstr, dispstr, writstr As String
Dim I, J, longs As Integer

writstr = Trim(Text10.Text)
longs = Val(Text8) * 2
ReDim sendbuf(longs + 12)

If writstr <> "" Then writstr = writstr + " "
For I = 1 To longs
    writstr = writstr + "00 "
Next

For I = 1 To longs
    bytes(I) = "&H" + Mid(writstr, (I - 1) * 3 + 1, 2)
Next


sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H9
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H10
sendbuf(8) = &H0
sendbuf(9) = Val(Text7)
sendbuf(10) = &H0
sendbuf(11) = Val(Text8)
sendbuf(12) = longs

For I = 1 To longs
   sendbuf(12 + I) = bytes(I)
Next
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 12 + longs
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command25_Click()
Dim sendbuf(11) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &HA
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H6
sendbuf(8) = &H0
sendbuf(9) = &H7
sendbuf(10) = &H0
sendbuf(11) = &H4
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command57_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr, hexd As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H6
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6          '指令长度
sendbuf(6) = Val(Text44)  '站号
sendbuf(7) = &H6          '功能码
sendbuf(8) = &H0
sendbuf(9) = &H1

If Check4.Value > 0 Then
    sendbuf(10) = &H80
    sendbuf(11) = Combo13.ListIndex + 2 * Combo14.ListIndex
Else
    sendbuf(10) = &H0
    sendbuf(11) = Combo13.ListIndex + 2 * Combo14.ListIndex
End If
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command61_Click()
On Error GoTo connerr
If Command61.Caption = "建立与读写器的TCP连接" Then
    Command61.Enabled = False
    Winsock3.Close
    Winsock3.Protocol = sckTCPProtocol
    Winsock3.RemoteHost = Trim(Text2.Text)
    Winsock3.RemotePort = CLng(Text1)
    Winsock3.Connect
    Timer6.Enabled = True
Else
'    Timer4.Enabled = False
'    Check15.Value = 0
    Winsock3.Close
    Frame6.Visible = False
    Command61.Caption = "建立与读写器的TCP连接"
End If
Exit Sub

connerr:
'    Timer4.Enabled = False
'    Check15.Value = 0
    Winsock3.Close
    Frame6.Visible = False
    Command61.Caption = "建立与读写器的TCP连接"
End Sub

Private Sub Command62_Click()
Dim sendbuf() As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendstr = "55AA01000006000300000001"
If Len(Trim(sendstr)) Mod 2 = 0 Then
    I = Len(Trim(sendstr)) / 2
    ReDim sendbuf(I)
    
    dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
    For J = 0 To I - 1
        sendbuf(J) = "&H" & Mid(sendstr, J * 2 + 1, 2)
        dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
    Next

    Winsock3.SendData sendbuf
    
    Form1.List1.AddItem (dispstr)
    Form1.List1.ListIndex = Form1.List1.ListCount - 1
End If
End Sub

Private Sub Command63_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

If Val(Text44) > 255 Then
    MsgBox "最大站号：255 ！请重新输入有效站号。", vbCritical + vbOKOnly, "提示"
    Text44.SetFocus
    Exit Sub
End If

If Val(Text45) > 255 Then
    MsgBox "最大站号：255 ！请重新输入有效站号。", vbCritical + vbOKOnly, "提示"
    Text45.SetFocus
    Exit Sub
End If

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H2
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H6
sendbuf(8) = &H0
sendbuf(9) = &H0
sendbuf(10) = &H0
sendbuf(11) = Val(Text45)
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command64_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H3
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6    '指令长度
sendbuf(6) = Val(Text44)
sendbuf(7) = &H6
sendbuf(8) = &H0
sendbuf(9) = &H2
sendbuf(10) = &H0
sendbuf(11) = Combo17.ListIndex + 1
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command65_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H4
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6           '指令长度
sendbuf(6) = Val(Text44)   '站号
sendbuf(7) = &H6           '功能码
sendbuf(8) = &H0
sendbuf(9) = &H46 + Combo18.ListIndex         '继电器寄存器地址

I = CLng(Text46)            '继电器开启时长
sendbuf(10) = Int(I / 256)
sendbuf(11) = I Mod 256
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Command66_Click()
Dim sendbuf(12) As Byte
Dim sendstr, dispstr As String
Dim I, J As Integer

sendbuf(0) = &H55
sendbuf(1) = &HAA
sendbuf(2) = &H5
sendbuf(3) = &H0
sendbuf(4) = &H0
sendbuf(5) = &H6           '指令长度
sendbuf(6) = Val(Text44)   '站号
sendbuf(7) = &H6           '功能码
sendbuf(8) = &H0
sendbuf(9) = &H46 + Combo18.ListIndex         '继电器寄存器地址

sendbuf(10) = 0
sendbuf(11) = 0
    
dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " SendTo：" + Mid(Winsock3.RemoteHost + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑发送："
For J = 0 To 11
    dispstr = dispstr + Right("00" + Hex(sendbuf(J)), 2) + " "
Next

Winsock3.SendData sendbuf

Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1
End Sub

Private Sub Form_Load()
Text2 = Form1.Text1.Text + "." + Form1.Text2.Text + "." + Form1.Text3.Text + "." + Form1.Text4.Text
Text1 = Form1.Text38

Combo13.AddItem ("刷卡不发声音")
Combo13.AddItem ("刷卡发出嘀声")
Combo13.ListIndex = 1

Combo14.AddItem ("无")
Combo14.AddItem (" 5ms")
Combo14.AddItem ("10ms")
Combo14.AddItem ("20ms")
Combo14.AddItem ("30ms")
Combo14.AddItem ("40ms")
Combo14.ListIndex = 0

Combo17.ListIndex = 1
Combo18.ListIndex = 1
End Sub

Private Sub Timer6_Timer()
Timer6.Enabled = False
Command61.Enabled = True
Command61.Caption = "建立与读写器的TCP连接"
MsgBox "与IP地址为：" + Trim(Text2.Text) + " 的TCP连接建立失败！", vbCritical + vbOKOnly, "提示"

End Sub

Private Sub Winsock3_Close()
'Timer4.Enabled = False
'Check15.Value = 0
Frame6.Visible = False
Command61.Caption = "建立与读写器的TCP连接"
End Sub

Private Sub Winsock3_Connect()
Timer6.Enabled = False
Frame6.Visible = True
Command61.Enabled = True
Command61.Caption = "断开与读写器的TCP连接"
End Sub

Private Sub Winsock3_DataArrival(ByVal bytesTotal As Long)
Dim dispstr, rstr As String
Dim doublecardhao
Dim para As Integer
Winsock3.GetData Udpdata

On Error Resume Next  '防止winsock阻塞

dispstr = Format(Now, "YYYY-MM-DD HH:MM:SS") & " From>>：" + Mid(Winsock3.RemoteHostIP + ":" + Format(Winsock3.RemotePort, "0") + "                        ", 1, 22) + "电脑接收："
For I = 0 To bytesTotal
    dispstr = dispstr + Right("00" + Hex(Udpdata(I)), 2) + " "
Next
    
If Form1.List1.ListCount > 100 Then
   Form1.List1.Clear
End If
Form1.List1.AddItem (dispstr)
Form1.List1.ListIndex = Form1.List1.ListCount - 1

If Udpdata(0) = &H55 And Udpdata(1) = &HAA Then
    Select Case Udpdata(2)
           Case &H1             '返回站号
                If bytesTotal >= 11 Then Text44 = Udpdata(bytesTotal - 1)
           Case &H2             '更改站号
                If bytesTotal >= 12 Then
                    Text44 = Udpdata(bytesTotal - 1)
                    MsgBox "站号已改为：" & Format(Udpdata(bytesTotal - 1), "0"), vbInformation + vbOKOnly, "提示"
                End If
           Case &H7            '驱动读卡器读卡 返回
                If bytesTotal >= 12 Then
                    answ = MsgBox("    读卡器已执行读卡操作，7 寄存器内保存了本次读卡操作是否成功的状态，是否要读出 7 寄存器内数据？", vbQuestion + vbOKCancel, "MODBUS测试程序")
                    If answ = vbOK Then
                       Text7.Text = 7     '根据7寄存器存放的读卡状态判断是否读卡成功。
                       Command11_Click
                    End If
                End If
           Case &H8         '读寄存器内数
                If bytesTotal >= 12 Then
                    rstr = ""
                    For I = 9 To 9 + Udpdata(8)
                        rstr = rstr + Right("00" + Hex(Udpdata(I)), 2) + " "
                    Next
                    Text10 = rstr
                    
                    If Val(Text7.Text) = 7 And Mid(Right("00000000" + DecToBin(Udpdata(9)), 8), 7, 1) = "1" Then '读卡成功，驱动发声
                       
                    End If
                End If
           Case &H9
                If Val(Text7.Text) >= 10 And Val(Text7.Text) <= 57 Then
                     answ = MsgBox("    存放IC卡扇区数据的寄存器数据更改成功，是否要驱动读卡器执行写卡操作？！", vbQuestion + vbOKCancel, "MODBUS测试程序")
                     If answ = vbOK Then
                         Command25_Click
                     End If
                Else
                     MsgBox "10指令写寄存器成功！", vbInformation, "MODBUS测试程序"
                End If
    End Select
End If
End Sub

Private Sub Winsock3_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)
Winsock3.Close
Frame6.Visible = False
Command61.Caption = "建立与读写器的TCP连接"
End Sub