frmregister.frm

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

            Settings = "E"
        End Select

        Settings = RateCb.Text + "," + Settings + "," + DataCb.Text + "," + StopCb.Text
        MSComPort.CommPort = PortCb.ListIndex + 1
        MSComPort.Settings = Settings
        MSComPort.PortOpen = True
        If MSComPort.PortOpen = True Then
            OpenFlag = True
            ComTimer.Enabled = True
            ConnetFlag = 0
            Option2(0).Enabled = False
            Option2(1).Enabled = False
            Frame1(1).Enabled = True
            CmdCom.Caption = "Close"
            Picture1.Picture = ImageList1.ListImages(2).Picture
            CmdSend.Enabled = True
            Me.Caption = "Modbus(RTU) Tool--Master  " + PortCb.Text + ":" + Settings
            Call WritePrivateProfileStringA("COMInfo", "ComPort", PortCb.ListIndex + 1, SaveDevFile)
            Call WritePrivateProfileStringA("COMInfo", "Rate", RateCb.Text, SaveDevFile)
            Call WritePrivateProfileStringA("COMInfo", "Check", CheckCb.Text, SaveDevFile)
            Call WritePrivateProfileStringA("COMInfo", "Data", DataCb.Text, SaveDevFile)
            Call WritePrivateProfileStringA("COMInfo", "Stop", StopCb.Text, SaveDevFile)
        End If
    Else
        CmdCom.Caption = "Open"             ''关闭串口
        Picture1.Picture = ImageList1.ListImages(3).Picture
        CmdSend.Enabled = False
        If OpenFlag = True Then
            OpenFlag = False
            MSComPort.PortOpen = False
        End If
        Option2(0).Enabled = True
        Option2(1).Enabled = True
        Frame2.Enabled = False
        AutoTimer.Enabled = False
        OverTimer.Enabled = False
        ComTimer.Enabled = False
        Frame1(1).Enabled = False
        Check2.Value = 0
    End If
    Exit Sub
ErrP:
    MsgBox Err.Description, vbCritical + vbOKOnly, "COM"
End Sub

Private Sub CmdExit_Click()
    Unload Me
End Sub

Private Sub CmdSave_Click()
Dim Save_FileName As String
Dim Save_FileNum As Long
Dim NoNulStr As String
Dim i As Integer
On Error Resume Next
    If Trim(SendText.Text) <> "" Then
        Save_FileName = App.Path + "\ModBus_" + Format(Now, "MMDD_HHMMSS") + ".txt"
        Save_FileNum = FreeFile
        Open Save_FileName For Binary As Save_FileNum
        NoNulStr = SendText.Text
        Put Save_FileNum, , NoNulStr
        Close Save_FileNum
        MsgBox "Save ok!", vbInformation + vbOKOnly, "Save"
    End If
    CmdSave.Enabled = False
End Sub

Private Sub CmdSend_Click()
Dim CmdStr As String, Temstr As String
Dim OutByte(511) As Byte
Dim k As Long, Num As Integer
Dim i As Integer, j As Integer

    If Trim(StartText.Text) = "" Then Exit Sub
    k = Val(StartText.Text)
    CmdStr = Hexn(k, 4)
    OutByte(0) = CbSlaveAddr.ListIndex + 1
    OutByte(2) = Val("&H" + Left(CmdStr, 2))        ''起始地址
    OutByte(3) = Val("&H" + Right(CmdStr, 2))
    Num = Val(NumText.Text)
    OutByte(4) = Num \ 256                            ''数量
    OutByte(5) = Num Mod 256
    If WFlag = False Then           ''读
        CmdID = 0
        OutByte(1) = &H3
        j = 6
    Else                            ''写
        CmdID = 1
        If Num > 1 Then             ''写多个寄存器
            OutByte(1) = &H10
            OutByte(6) = Num * 2
            For i = 1 To Num
                k = (i - 1) * 2
                OutByte(7 + k) = Val(MSGrid.TextMatrix(i, 1))
                OutByte(8 + k) = Val(MSGrid.TextMatrix(i, 2))
            Next i
            j = 7 + Num * 2
        Else
            OutByte(1) = &H6        ''写单个寄存器,不需要寄存器的数量
            OutByte(4) = Val(MSGrid.TextMatrix(1, 1))
            OutByte(5) = Val(MSGrid.TextMatrix(1, 2))
            j = 6
        End If
    End If
    CmdStr = OutByte
    CmdStr = MidB(CmdStr, 1, j)
    If CurIndex = 0 Then        ''串口
        k = Crc_16(CmdStr)
        OutByte(j) = k Mod 256
        OutByte(j + 1) = k \ 256                      ''数量
        CmdStr = OutByte
        CmdStr = MidB(CmdStr, 1, j + 2)
    Else                        ''网络
        k = Val("&H" + SignText.Text + "&")
        OutByte(0) = k \ 256
        OutByte(1) = k Mod 256
        OutByte(2) = &H0
        OutByte(3) = &H0
        OutByte(4) = &H0
        OutByte(5) = j
        Temstr = OutByte
        CmdStr = MidB(Temstr, 1, 6) + CmdStr
    End If
    If CmdID = 0 Then AutoStr = CmdStr
    SendToK61 CmdStr
    Frame2.Enabled = True
End Sub

Private Sub CmdTCP_Click()
    Frame1(1).Enabled = False
    If CmdTCP.Caption = "Apply" Then
        Call WritePrivateProfileStringA("NetInfo", "RemotePort", RemoteText.Text, SaveDevFile)
        Call WritePrivateProfileStringA("NetInfo", "NetIP", IpText.Text, SaveDevFile)
        If SockeWay = True Then
            Call WritePrivateProfileStringA("NetInfo", "SockeWay", 0, SaveDevFile)
        Else
            Call WritePrivateProfileStringA("NetInfo", "SockeWay", 1, SaveDevFile)
        End If
        CmdTCP.Caption = "Stop"
        ReNetTimer.Enabled = True
        Option2(0).Enabled = False
        Option2(1).Enabled = False
        ReNetTimer_Timer
        CmdSend.Enabled = False
    Else
        Me.MousePointer = 0
        CmdTCP.Caption = "Apply"
        AutoTimer.Enabled = False
        If ConnetFlag = True Then
            Winsock1_Close 1
        End If
        ReNetTimer.Enabled = False
        Picture2.Picture = ImageList1.ListImages(5).Picture
        CmdSend.Enabled = False
        Me.Caption = "IDC611_Modbus_tool--Master"
        Option2(0).Enabled = True
        Option2(1).Enabled = True
        Frame2.Enabled = False
        OverTimer.Enabled = False
        Winsock1(0).Close
    End If
End Sub

Private Sub Form_Load()
Dim i As Integer

    Me.Top = (Screen.Height - Me.Height) / 2
    Me.Left = (Screen.Width - Me.Width) / 2
    FraCom.ZOrder 0
    TemSkPort = 0
    CmdID = -1
    Me.Icon = ImageList1.ListImages(1).Picture
    Picture1.Picture = ImageList1.ListImages(3).Picture
    Picture2.Picture = ImageList1.ListImages(5).Picture
    
    OpenFlag = False
    ConnetFlag = False
    SockeLoadFlag = False
    SockeWay = False
    CmdSend.Enabled = False
    Frame2.Enabled = False
    Frame1(1).Enabled = False
    GetValFlag = False
    
    AutoTimer.Enabled = False
    AutoTimer.Interval = 1500
    OverTimer.Enabled = False
    OverTimer.Interval = 4000
    ComTimer.Enabled = False
    ComTimer.Interval = 100
    ReNetTimer.Enabled = False
    ReNetTimer.Interval = 5000
    
    Initface
    ReadConfig
    MSGrid.Cols = 4
    MSGrid.ColWidth(0) = 850
    MSGrid.ColWidth(1) = 950
    MSGrid.ColWidth(2) = 950
    MSGrid.ColWidth(3) = 1200
    MSGrid.TextMatrix(0, 0) = "Address"
    MSGrid.TextMatrix(0, 1) = "High 8 bit"
    MSGrid.TextMatrix(0, 2) = "Low 8 bit"
    MSGrid.TextMatrix(0, 3) = "Value"
    For i = 0 To 3
        MSGrid.ColAlignment(i) = 4
    Next i
    MaxVisbleRows = MSGrid.Height \ MSGrid.RowHeight(0) - 1
    InitGrid
    RemoteText.Text = "7100"
End Sub

Private Sub Initface()
Dim i As Integer

    For i = 1 To 15
        PortCb.AddItem "COM" + CStr(i)
    Next i
    PortCb.ListIndex = 0
    
    With RateCb             '波特率
        .AddItem "110"
        .AddItem "300"
        .AddItem "600"
        .AddItem "1200"
        .AddItem "2400"
        .AddItem "4800"
        .AddItem "9600"
        .AddItem "14400"
        .AddItem "19200"
        .AddItem "38400"
        .AddItem "57600"
        .AddItem "115200"
        .ListIndex = 6
    End With
    
    With CheckCb
        .AddItem "None"     '校验方式
        .AddItem "Odd"
        .AddItem "Even"
        .ListIndex = 0
    End With
        
    DataCb.AddItem "6"          '数据位
    DataCb.AddItem "7"
    DataCb.AddItem "8"
    DataCb.ListIndex = 2
    
'   stopcb.AddItem "1.5"       '停止位
    StopCb.AddItem "1"
    StopCb.AddItem "2"
    StopCb.ListIndex = 0
    
    For i = 1 To 255
        CbSlaveAddr.AddItem i
    Next i
    CbSlaveAddr.ListIndex = 0
    SAddr = 1
End Sub

Sub ReadConfig()
Dim i As Long
Dim L As Long
Dim St1 As String
    
    If Dir(SaveDevFile) = "" Then Exit Sub
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("COMInfo", "ComPort", "", St1, 20, SaveDevFile)
    If i > 0 Then
        L = Val(Left(St1, i))
        PortCb.ListIndex = SendMessage(PortCb.hwnd, CB_FINDSTRINGEXACT, -1, ByVal "COM" + CStr(L))
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("COMInfo", "Stop", "", St1, 20, SaveDevFile)
    If i > 0 Then
        L = Val(Left(St1, i))
        StopCb.ListIndex = SendMessage(StopCb.hwnd, CB_FINDSTRINGEXACT, -1, ByVal CStr(L))
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("COMInfo", "Rate", "", St1, 20, SaveDevFile)
    If i > 0 Then
        L = Val(Left(St1, i))
        RateCb.ListIndex = SendMessage(RateCb.hwnd, CB_FINDSTRINGEXACT, -1, ByVal CStr(L))
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("COMInfo", "Data", "", St1, 20, SaveDevFile)
    If i > 0 Then
        L = Val(Left(St1, i))
        DataCb.ListIndex = SendMessage(DataCb.hwnd, CB_FINDSTRINGEXACT, -1, ByVal CStr(L))
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("COMInfo", "Check", "", St1, 20, SaveDevFile)
    If i > 0 Then
        St1 = Left(St1, i)
        CheckCb.ListIndex = SendMessage(CheckCb.hwnd, CB_FINDSTRINGEXACT, -1, ByVal St1)
    End If
    
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("NetInfo", "RemotePort", "", St1, 20, SaveDevFile)
    If i > 0 Then
        RemoteText.Text = Val(Left(St1, i))
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("NetInfo", "NetIP", "", St1, 20, SaveDevFile)
    If i > 0 Then
        IpText.Text = Left(St1, i)
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("NetInfo", "SockeWay", "", St1, 20, SaveDevFile)
    If i > 0 Then
        If Val(Left(St1, i)) = 1 Then
            SockeWay = False
            Option3(1).Value = True
        Else
            SockeWay = True
            Option3(0).Value = True
        End If
    End If
    St1 = String(20, " ")
    i = GetPrivateProfileStringA("NetInfo", "Slave", "", St1, 20, SaveDevFile)
    If i > 0 Then
        SAddr = Left(St1, i)
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If OpenFlag = True Then MSComPort.PortOpen = False
    If SockeLoadFlag = True Then
        If Winsock1(1).State <> sckClosed Then Winsock1(1).Close
        Unload Winsock1(1)
        Winsock1(0).Close
    End If
    If UnloadFlag = 0 Then
        UnloadFlag = 2
        Unload Form1
    End If
End Sub

Private Sub Form_Resize()
    If Me.WindowState <> 1 Then
        Me.Height = 8000
        Me.Width = 10340
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If UnloadFlag = 2 Then End
End Sub

Private Sub HexText_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 IpText_Click()
    DopSitY = IpText.SelStart
End Sub

Private Sub IpText_DblClick()
Dim CurIco As Integer
Dim DopDc(3) As Integer
Dim SelL As Integer
Dim SeStr As String
Dim L As Integer
Dim i As Integer
Dim Dc As Integer

    SeStr = IpText.Text
    Dc = 0
    L = 1
    Do
        i = InStr(L, SeStr, ".")
        If i > 0 Then
            DopDc(Dc) = i
            Dc = Dc + 1
            L = i + 1
        Else
            If L > 1 And Dc < 3 Then DopDc(Dc) = Len(SeStr) + 1
            Exit Do
        End If
    Loop While (True)
    If DopDc(0) > 0 Then
        If DopSitY < DopDc(0) Then
            CurIco = 0
            SelL = DopDc(0) - 1
        ElseIf DopSitY < DopDc(1) Then
            CurIco = DopDc(0)
            SelL = DopDc(1) - DopDc(0) - 1
        ElseIf DopSitY < DopDc(2) Then
            CurIco = DopDc(1)
            SelL = DopDc(2) - DopDc(1) - 1
        Else
            CurIco = DopDc(2)
            SelL = Len(Mid(SeStr, DopDc(2) + 1))
        End If
        IpText.SelStart = CurIco
        IpText.SelLength = SelL
    End If
End Sub