frmregister.frm

一个读取支持modbus协议的设备的数据工具

        End If
    Next i
ErrP:
End Sub
                    
Private Sub Option2_Click(Index As Integer)
    CurIndex = Index
    ConnetFlag = False
    OpenFlag = False
    ReNetTimer.Enabled = False
    Me.MousePointer = 0
    OverTimer.Enabled = False
    CmdSend.Enabled = False
    If Index = 0 Then
        FraTcp.Visible = False
        FraCom.Visible = True
        Picture1.Picture = ImageList1.ListImages(3).Picture
    Else
        FraTcp.Visible = True
        FraCom.Visible = False
        Picture2.Picture = ImageList1.ListImages(5).Picture
    End If
End Sub

Private Sub Option3_Click(Index As Integer)
    If Index = 0 Then
        SockeWay = True
'        RemoteText.Enabled = False
    Else
        SockeWay = False
'        RemoteText.Enabled = True
    End If
End Sub

Private Sub Option4_Click(Index As Integer)
    If Index = 0 Then
        AscFlag = True
    Else
        AscFlag = False
    End If
End Sub

Private Sub OverTimer_Timer()
    OverTimer.Enabled = False
    Check2.Value = 0
    Me.MousePointer = 0
    SendText.Text = SendText.Text + "Time out!" + vbNewLine
    CmdSend.Enabled = True
End Sub

Private Sub RemoteText_KeyPress(KeyAscii As Integer)
Dim ChStr As String

    If KeyAscii = 8 Then Exit Sub
    ChStr = Chr(KeyAscii)
    If (ChStr < "0" Or ChStr > "9") Then    '''非数字
        KeyAscii = 0
    End If
End Sub

Private Sub ReNetTimer_Timer()
'''重新连接时钟，每5秒触发一次
On Error Resume Next
    
    If SockeLoadFlag = True Then
        If Winsock1(1).State <> sckConnected Then
            If Winsock1(1).State <> sckClosed Then
                Winsock1(1).Close
            End If
            Unload Winsock1(1)
            SockeLoadFlag = False
        Else
            Exit Sub
        End If
    End If
    If SockeWay = False Then
        Winsock1(0).Close
        Load Winsock1(1)
        SockeLoadFlag = True
        Winsock1(1).RemoteHost = IpText.Text
        Winsock1(1).RemotePort = Val(RemoteText.Text)
        TemSkPort = TemSkPort + 1
        Winsock1(1).Connect
        Me.Caption = "Modbus(TCP) Tool--Master:Connect..."
    Else
        Winsock1(0).Close
        Winsock1(0).LocalPort = Val(RemoteText.Text)
        Winsock1(0).Listen
        Me.Caption = "Modbus(TCP) Tool--Master:Listen..."
    End If
End Sub

Private Sub SendText_Change()
    If Len(SendText.Text) >= 20480 Then
        SendText.Text = ""
        CmdSave.Enabled = False
    Else
        Call SendMessage(SendText.hwnd, WM_HSCROLL1, SB_END, ByVal 0&)
        CmdSave.Enabled = True
    End If
End Sub

Private Sub SignText_KeyPress(KeyAscii As Integer)
Dim ChStr As String
    If KeyAscii = 8 Then Exit Sub
    ChStr = Chr(KeyAscii)
    If (ChStr < "0" Or ChStr > "9") Then    '''非数字
        KeyAscii = 0
    End If
End Sub


Private Sub StartText_Change()
Dim i As Integer
Dim j As Integer
Dim Temstr As String
Dim k As Long
    If GetValFlag = True Then Exit Sub
    If StartText.Text = "" Then Exit Sub
    GetValFlag = True
    k = Val(StartText.Text)
    If k > 32767 Then
        k = 32767
        StartText.Text = k
    End If
    InitGrid
    Check2.Value = 0
    AutoStr = ""
    Frame2.Enabled = False
    GetValFlag = False
End Sub

Private Sub StartText_KeyPress(KeyAscii As Integer)
Dim ChStr As String
    If KeyAscii = 8 Then Exit Sub
    If KeyAscii < &H30 Or KeyAscii > &H39 Then KeyAscii = 0
End Sub

Private Sub Text2_LostFocus()
    Text2.Visible = False
End Sub

Private Sub Text3_Change()
Dim k As Long
Dim j As Long
Dim TmStr As String
    k = Val(Text3.Text)
    If k > 65535 Then
        k = 65535
        Text3.Text = k
    End If
    TmStr = Hexn(k, 4)
    j = Val("&H" + TmStr)
    Text4.Text = j
End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
    If KeyAscii <> 8 Then
        If KeyAscii < &H30 Or KeyAscii > &H39 Then KeyAscii = 0
    End If
End Sub

Private Sub Winsock1_Close(Index As Integer)
On Error Resume Next
    If Index < 1 Then Exit Sub
    If Winsock1(1).State <> sckClosed Then
        Winsock1(1).Close
        Unload Winsock1(1)
        SockeLoadFlag = False
        Winsock1(0).Close
    End If
    ConnetFlag = False
    OpenFlag = False
    Frame2.Enabled = False
    Frame1(1).Enabled = False
    Check2.Value = 0
    ReNetTimer.Enabled = True
    Picture2.Picture = ImageList1.ListImages(5).Picture
    CmdSend.Enabled = False
    Me.MousePointer = 0
    Beep
End Sub

Private Sub Winsock1_Connect(Index As Integer)
    ReNetTimer.Enabled = False
    ConnetFlag = True
    Frame1(1).Enabled = True
    Me.Caption = "Modbus(TCP) Tool--Master:Client"
    Picture2.Picture = ImageList1.ListImages(4).Picture
    CmdSend.Enabled = True
    Beep
    Beep
End Sub

Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
    
    If StrComp(Winsock1(Index).RemoteHostIP, IpText.Text, vbTextCompare) <> 0 Then Exit Sub
    If SockeLoadFlag = True Then
        Winsock1(1).Close
        Unload Winsock1(1)
        SockeLoadFlag = False
    End If
    Load Winsock1(1)
    SockeLoadFlag = True
    If Winsock1(1).State <> sckClosed Then Winsock1(1).Close
    Winsock1(1).RemotePort = Winsock1(0).RemotePort
    Winsock1(1).LocalPort = 0
    Winsock1(1).Accept requestID
    ConnetFlag = True
    ReNetTimer.Enabled = False
    Frame1(1).Enabled = True
    Me.Caption = "Modbus(TCP) Tool--Master:Server"
    Picture2.Picture = ImageList1.ListImages(4).Picture
    CmdSend.Enabled = True
    Beep
    Beep
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim InData() As Byte
Dim TemDataStr As String
Dim i As Integer
Dim L As Integer
Dim Temstr As String
On Error GoTo ErrP

    If Index < 1 Or ConnetFlag = False Then Exit Sub
    If Winsock1(Index).State <> sckConnected Then Exit Sub
    ReNetTimer.Enabled = False
    Winsock1(Index).GetData InData
    TemDataStr = InData
    
    Temstr = ""
    If AscFlag = False Then
        L = LenB(TemDataStr)
        For i = 1 To L
            Temstr = Temstr + Hexn(AscB(MidB(TemDataStr, i, 1)), 2) + " "
        Next i
    Else
        Temstr = StrConv(TemDataStr, vbUnicode)
    End If
    SendText.Text = SendText.Text + "Receive:" + Temstr + vbNewLine
    ReceiveStr = ReceiveStr + TemDataStr
    Process_Netdata ReceiveStr
ErrP:
End Sub

Private Sub Winsock1_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)
    If Index > 0 And ConnetFlag = True Then
        Winsock1_Close Index
    End If
End Sub

Private Sub Process_Netdata(Datastr As String)
''处理收到的数据
Dim i As Integer, j As Integer, k As Integer
Dim L As Integer, sum As Integer
Dim Temstr As String, ReCmdID As Integer
Dim OkFlag As Boolean
    
    For i = 0 To 3
        k = 1
Repro:
        Temstr = Datastr
        j = 0
        OkFlag = False
        Select Case i
        Case 0
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H3), vbBinaryCompare)
        Case 1
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H6), vbBinaryCompare)
        Case 2
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H10), vbBinaryCompare)
        Case 3
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H83), vbBinaryCompare)
        End Select
        If j > 0 Then
            If j > 6 Then
                Temstr = MidB(Temstr, j - 6)
                sum = AscB(MidB(Temstr, 3, 1)) + AscB(MidB(Temstr, 4, 1))   ''modbus_tcp
                If sum = 0 Then
                    L = AscB(MidB(Temstr, 6, 1))
                    Temstr = MidB(Temstr, 7)
                    sum = LenB(Temstr)
                    If L <= sum Then
                        OkFlag = True
                        OverTimer.Enabled = False       ''关闭超时时钟
                        If AutoTimer.Enabled = False Then CmdSend.Enabled = True
                        Me.MousePointer = 0
                        ReCmdID = AscB(MidB(Temstr, 2, 1))
                        Select Case ReCmdID
                        Case &H6, &H10
                            SendText.Text = SendText.Text + "Write succeeded!" + vbNewLine
                        Case &H3
                            Process_data MidB(Temstr, 4)
                        Case &H83
                            SendText.Text = SendText.Text + "Command error!" + vbNewLine
                        End Select
                    End If
                End If
            Else
                k = j + 1
                GoTo Repro
            End If
        End If
        If OkFlag = True Then
            Datastr = MidB(Datastr, L + j)
            Exit Sub
        End If
    Next i
End Sub

Private Sub Process_Comdata(Datastr As String)
''处理收到的数据
Dim i As Integer, j As Integer, k As Integer
Dim L As Integer, Temstr As String
Dim sum As Long, ReCmdID As Integer
Dim OkFlag As Boolean

    L = 0
    For i = 0 To 3
        k = 1
Repro:
        Temstr = Datastr
        j = 0
        OkFlag = False
        Select Case i
        Case 0
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H3), vbBinaryCompare)
        Case 1
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H6), vbBinaryCompare)
        Case 2
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H10), vbBinaryCompare)
        Case 3
            j = InStrB(k, Temstr, ChrB(SAddr) + ChrB(&H83), vbBinaryCompare)
        End Select
        If j > 0 Then
            Temstr = MidB(Temstr, j)
            L = AscB(MidB(Temstr, 2, 1))
            Select Case L
            Case 3
                L = AscB(MidB(Temstr, 3, 1))
                L = L + 5
            Case &H6, &H10
                L = 8
            Case Else       ''&h83
                L = 6
            End Select
            If L <= LenB(Temstr) Then
                Temstr = MidB(Temstr, 1, L)
                sum = Crc_16(Temstr)
                If sum = 0 Then
                    OkFlag = True
                    OverTimer.Enabled = False       ''关闭超时时钟
                    If AutoTimer.Enabled = False Then CmdSend.Enabled = True
                    Me.MousePointer = 0
                    ReCmdID = AscB(MidB(Temstr, 2, 1))
                    Temstr = MidB(Temstr, 1, L - 2)
                    Select Case ReCmdID
                    Case &H6, &H10
                        SendText.Text = SendText.Text + "Write succeeded!" + vbNewLine
                    Case &H3
                        Process_data MidB(Temstr, 4)
                    Case &H83
                        SendText.Text = SendText.Text + "Command error!" + vbNewLine
                    End Select
                Else
                    k = j + 1
                    If i < 3 Then
                        GoTo Repro
                    Else
                        Datastr = RightB(Datastr, 2)
                    End If
                End If
            End If
        End If
        If OkFlag = True Then
            Datastr = MidB(Datastr, L + j)
            Exit Sub
        End If
    Next i
    If L = 0 Then Datastr = RightB(Datastr, 2)
End Sub

Private Sub ComTimer_Timer()
Dim i As Long
On Error Resume Next
Dim DisStr As String
Dim L As Long
Dim Temstr As String

    Do
        If MSComPort.InBufferCount <= 0 Then Exit Do
        DisStr = MSComPort.Input
        Temstr = ""
        If AscFlag = False Then
            L = LenB(DisStr)
            For i = 1 To L
                Temstr = Temstr + Hexn(AscB(MidB(DisStr, i, 1)), 2) + " "
            Next i
        Else
            Temstr = StrConv(DisStr, vbUnicode)
        End If
        SendText.Text = SendText.Te