vfd-con485.bas

modbusRTU

Attribute VB_Name = "Module1"
Option Explicit

Public DataVW(100) As Long
Public DataVD(100) As Single
Public DataVB(100) As Integer
Public ResultBit(0 To 20) As Integer

Public inSafeArray() As String
Public AddPLC As String
Public FlagRec As Boolean
Public FlagVW As Boolean
Public FlagVD As Boolean
Public FlagVB As Boolean

Public BitNumber As Integer

Public ReadNumberB As Integer
Public ReadNumberW As Integer
Public ReadNumberD As Integer

Public AddrReadB As String
Public AddrReadW As String
Public AddrReadD As String

Public Bit(0 To 7) As Integer


 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)


'CRC校验码生成
 Function CrcResult(ByVal Data As Long, ByVal Genpoly As Long, ByVal CrcData As Long) As Long
    Dim n As Integer
    Data = Data * 2
    For n = 8 To 1 Step -1
        Data = Fix(Data / 2)
        If ((Data Xor CrcData) And 1) Then
            CrcData = Fix(CrcData / 2) Xor Genpoly
        Else
            CrcData = Fix(CrcData / 2)
        End If
    Next n
    CrcResult = CrcData
End Function


Function Chr_4(str As String) As String
    Dim Lenstr As Integer
    Lenstr = Len(str)

    If Lenstr = 1 Then str = "000" + str
    If Lenstr = 2 Then str = "00" + str
    If Lenstr = 3 Then str = "0" + str
    Chr_4 = str
End Function

Function Chr_8(str As String) As String
    Dim Lenstr As Integer
    Lenstr = Len(str)

    If Lenstr = 1 Then str = "0000000" + str
    If Lenstr = 2 Then str = "000000" + str
    If Lenstr = 3 Then str = "00000" + str
    If Lenstr = 4 Then str = "0000" + str
    If Lenstr = 5 Then str = "000" + str
    If Lenstr = 6 Then str = "00" + str
    If Lenstr = 7 Then str = "0" + str
   
    Chr_8 = str
End Function
Function Chr_2(str As String) As String
    Dim Lenstr As Integer
    Lenstr = Len(str)

    If Lenstr = 1 Then str = "0" + str
    Chr_2 = str
End Function

Function HextoSng(strhex As String) As String
    Dim l As Long
    Dim f As Single
    Dim s As String
    
    'strhex = "4131999A"

    l = Val("&H" & strhex)
    CopyMemory f, l, 4
    f = f
    s = Format(f, "0.000")
    HextoSng = s
End Function

Function SngtoHex(SngData As Single) As String
  Dim lngNum     As Long
 
  'SngData = 25.5
  CopyMemory lngNum, SngData, 4
   SngtoHex = Chr_8(Hex(lngNum))
   SngtoHex = Mid(SngtoHex, 1, 4) + Mid(SngtoHex, 5, 4)
   

End Function
Public Function ProcessRecVW()
Dim strVW As String

    Dim i As Integer

        For i = 3 To FrmMain1.MSComm1.RThreshold - 3 Step 2
          strVW = inSafeArray(i) + inSafeArray(i + 1)
         DataVW((i - 3) / 2) = "&H" & strVW
         
        Next i
            
End Function
Public Function ProcessRecBit(BitNumber As Integer)
Dim strVB As String
 Dim i, j As Integer

     For i = 3 To FrmMain1.MSComm1.RThreshold - 3 Step 2
            strVB = inSafeArray(i)
          DataVB((i - 3) / 2) = "&H" & strVB
         
         For j = 7 To 0 Step -1
            If DataVB((i - 3) / 2) \ (2 ^ j) Then
                Bit(j) = 1
            Else
                Bit(j) = 0
            End If
            DataVB((i - 3) / 2) = DataVB((i - 3) / 2) - (2 ^ j) * Bit(j)
         Next j
             ResultBit((i - 3) / 2) = Bit(BitNumber)
    Next i
        
  
            
End Function
Public Function ProcessRecVD()
Dim strVD As String

    Dim i As Integer

        For i = 3 To FrmMain1.MSComm1.RThreshold - 3 Step 4
          strVD = inSafeArray(i) + inSafeArray(i + 1) + inSafeArray(i + 2) + inSafeArray(i + 3)
         DataVD((i - 3) / 4) = HextoSng(strVD)
         
        Next i
            
End Function

Public Function ReadVW(FlagRec As Boolean, AddrReadW As String, ReadNumberW As Integer)
Dim i As Integer

If FlagRec = 0 Then
         FrmMain1.MSComm1.RThreshold = 5 + ReadNumberW * 2
         Call FrameFun(AddPLC, 3, AddrReadW / 2, ReadNumberW)
         FlagVW = True

Else
         Call ProcessRecVW
         FlagVW = False
        For i = 0 To (FrmMain1.MSComm1.RThreshold - 5) / 2 - 1
                FrmMain1.TextDataRW.Text = FrmMain1.TextDataRW.Text & " " & DataVW(i) & Chr(13)
        Next i
       
End If

End Function
Public Function ReadVD(FlagRec As Boolean, AddrReadD As String, ReadNumberD As Integer)
Dim i As Integer

If FlagRec = 0 Then
        FrmMain1.MSComm1.RThreshold = 5 + ReadNumberD * 4
        Call FrameFun(AddPLC, 3, AddrReadD / 2, ReadNumberD * 2)
        FlagVD = True
Else
        Call ProcessRecVD
        FlagVD = False
        For i = 0 To (FrmMain1.MSComm1.RThreshold - 5) / 4 - 1
                FrmMain1.TextDataRD.Text = FrmMain1.TextDataRD.Text & " " & DataVD(i) & Chr(13)
        Next i
       
End If
End Function
Public Function WriteVW(AddrWrite As String, DataWrite As Integer)
       Call FrameFun(AddPLC, 6, AddrWrite / 2, DataWrite)
      FrmMain1.MSComm1.RThreshold = 8
End Function
Public Function WriteVD(AddrWrite As String, DataWrite As Single)
       Call FrameFunTwo(AddPLC, 10, AddrWrite / 2, 2, 4, DataWrite)
       FrmMain1.MSComm1.RThreshold = 8
End Function
Public Function GetBit(FlagRec As Boolean, AddrReadB As String, BitNumber As Integer, ReadNumberB As Integer)
Dim i As Integer

If FlagRec = 0 Then
         FrmMain1.MSComm1.RThreshold = 5 + ReadNumberB * 2
         Call FrameFun(AddPLC, 3, AddrReadB / 2, ReadNumberB)
         FlagVB = True

Else
        Call ProcessRecBit(BitNumber)
        FlagVB = False
          For i = 0 To (FrmMain1.MSComm1.RThreshold - 5) / 2 - 1
                FrmMain1.TextDataRB.Text = FrmMain1.TextDataRB.Text & " " & ResultBit(i) & Chr(13)
          Next i
        
End If

End Function
Public Function SetBitTrue(AddrWrite As String, BitNumber As Integer)
      Call FrameFun(AddPLC, 6, AddrWrite / 2, -1)
      FrmMain1.MSComm1.RThreshold = 8
End Function
Public Function SetBitFalse(AddrWrite As String, BitNumber As Integer)
      Call FrameFun(AddPLC, 6, AddrWrite / 2, 0)
      FrmMain1.MSComm1.RThreshold = 8
End Function

Public Function FrameFun(Addr As String, Cmd As String, Register As String, Data As Integer)
    Dim ComStr          As String
    Dim Temp(6)         As String
    Dim BL              As Byte                       '数据长度
    Dim n               As Byte                       '循环量
    Dim CRC             As Long                       'CRC寄存器
    Dim fx()            As Byte

    Dim hexchrlen%
    Dim Hexchr          As String
    Dim hexcyc%
    Dim hexmid          As Byte
    Dim hexmiddle       As String
    Dim hexchrgroup()   As Byte
    Dim i               As Integer

    '--------------------------------------------------------
    ' 获得数据串

    FrmMain1.MSComm1.OutBufferCount = 0
    Temp(0) = Chr_2(Addr)
    Temp(1) = Chr_2(Cmd)
    Temp(2) = Chr_4(Hex(Register))
    Temp(3) = Chr_4(Hex(Data))

    ComStr = Temp(0) + Temp(1) + Temp(2) + Temp(3)

    '---CRC -----------------------------------------------------
    BL = Len(ComStr) / 2
    ReDim fx(BL + 1)                                  '按命令长度重新定义数组
    CRC = &HFFFF&                                     'CRC初值
    For n = 0 To BL - 1
        fx(n) = CLng("&H" & Mid(ComStr, 2 * n + 1, 2)) '分解命令为字节
        CRC = CrcResult(fx(n), &HA001&, CRC)          'CRC校验码生成调用
    Next

    fx(BL) = CByte(CRC And &HFF&)                     '得到的校验低位
    fx(BL + 1) = CByte(Fix(CRC / 256) And &HFF&)      '得到的校验高位
    Temp(4) = Chr_2(Hex(fx(BL)))
    Temp(5) = Chr_2(Hex(fx(BL + 1)))
    ComStr = Trim(ComStr + Temp(4) + Temp(5))

    '检查数据是否正确
    hexchrlen = Len(ComStr)
    For hexcyc = 1 To hexchrlen                       '检查Text1文本框内数值是否合适
        Hexchr = Mid(ComStr, hexcyc, 1)
        If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
            MsgBox "无效的数值，请重新输入", , "错误信息"
            Exit Function
        End If
    Next

    '分解数据 为 二进制发送 模式

   ' ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
    ReDim hexchrgroup(hexchrlen \ 2 - 1) ' As Byte
    For hexcyc = 1 To hexchrlen Step 2                '将文本框内数值分成两个、两个
       
         Hexchr = Mid(ComStr, hexcyc, 2)
    '    Hexchr = "FF"
        hexmid = Val("&H" & CStr(Hexchr))
        hexchrgroup(i) = hexmid
       i = i + 1
    Next

        FrmMain1.MSComm1.Output = hexchrgroup ''''ComStr '
        Sleep 100



End Function
Public Function FrameFunTwo(Addr As String, Cmd As String, Register As String, Number As String, ByteNum As String, Data As Single)
    Dim ComStr          As String
    Dim Temp(7)         As String
    Dim BL              As Byte                       '数据长度
    Dim n               As Byte                       '循环量
    Dim CRC             As Long                       'CRC寄存器
    Dim fx()            As Byte

    Dim hexchrlen%
    Dim Hexchr          As String
    Dim hexcyc%
    Dim hexmid          As Byte
    Dim hexmiddle       As String
    Dim hexchrgroup()   As Byte
    Dim i               As Integer

    '--------------------------------------------------------
    ' 获得数据串

    FrmMain1.MSComm1.OutBufferCount = 0
    Temp(0) = Chr_2(Addr)
    Temp(1) = Chr_2(Cmd)
    Temp(2) = Chr_4(Hex(Register))
    Temp(3) = Chr_4(Hex(Number))
    Temp(4) = Chr_2(Hex(ByteNum))
    Temp(5) = SngtoHex(Data)

    ComStr = Temp(0) + Temp(1) + Temp(2) + Temp(3) + Temp(4) + Temp(5)

    '---CRC -----------------------------------------------------
    BL = Len(ComStr) / 2
    ReDim fx(BL + 1)                                  '按命令长度重新定义数组
    CRC = &HFFFF&                                     'CRC初值
    For n = 0 To BL - 1
        fx(n) = CLng("&H" & Mid(ComStr, 2 * n + 1, 2)) '分解命令为字节
        CRC = CrcResult(fx(n), &HA001&, CRC)          'CRC校验码生成调用
    Next

    fx(BL) = CByte(CRC And &HFF&)                     '得到的校验低位
    fx(BL + 1) = CByte(Fix(CRC / 256) And &HFF&)      '得到的校验高位
    Temp(6) = Chr_2(Hex(fx(BL)))
    Temp(7) = Chr_2(Hex(fx(BL + 1)))
    ComStr = Trim(ComStr + Temp(6) + Temp(7))

    '检查数据是否正确
    hexchrlen = Len(ComStr)
    For hexcyc = 1 To hexchrlen                       '检查Text1文本框内数值是否合适
        Hexchr = Mid(ComStr, hexcyc, 1)
        If InStr("0123456789ABCDEFabcdef", Hexchr) = 0 Then
            MsgBox "无效的数值，请重新输入", , "错误信息"
            Exit Function
        End If
    Next

    '分解数据 为 二进制发送 模式
   
   ' ReDim hexchrgroup(1 To hexchrlen \ 2) As Byte
    ReDim hexchrgroup(hexchrlen \ 2 - 1) 'As Byte
    For hexcyc = 1 To hexchrlen Step 2                '将文本框内数值分成两个、两个
       
         Hexchr = Mid(ComStr, hexcyc, 2)
    '    Hexchr = "FF"
        hexmid = Val("&H" & CStr(Hexchr))
        hexchrgroup(i) = hexmid
     
        i = i + 1

    Next
     
        FrmMain1.MSComm1.Output = hexchrgroup ''''ComStr '
        Sleep 100
   
End Function