plc.bas

用模块写的plc通信,用于计算机与三菱plc通信

Attribute VB_Name = "PLC"
 Option Explicit
   Public RcvData() As Byte        '接收数组
   Public RcvLen As Integer        '接收数组长度
   Public Flag As Integer          '状态标志
   Public Num As Integer           '重发次数计数器
   Public RcvFinFlag As Boolean    '接收完成标志
   Public SaveString As String     '输入命令暂存字符串
 Public Sub Dread(instring As String, ByteCount As Integer)        '读 D
  Dim s As String
  Flag = 0
  s = "0" & TransAd(instring) & Format(ByteCount, "00")
  Send s
 End Sub
  Public Sub Dwrite(instring As String, ByteCount As Integer, Data As String)        '写 D
  Dim str1 As String
  Dim s As String
  Flag = 1
 Select Case ByteCount
 Case 2
    str1 = Exchange(Data)
 Case 4
    str1 = Exchange(Mid(Data, 1, 4)) & Exchange(Mid(Data, 5, 4))
 End Select
    s = "1" & TransAd(instring) & Format(ByteCount, "00") & str1
   Send s
 End Sub
 Public Sub BitForce(instring As String, AtOn As Boolean)         'Bit元件置位/复位
   Dim s As String
   If AtOn = True Then
     Flag = 7
     s = "7" & TransAd(instring)
   Else
     Flag = 8
     s = "8" & TransAd(instring)
   End If
   Send s
 End Sub
 Public Sub BitSearch(instring As String)             'Bit元件查询状态
    Dim s As String
    Flag = 9
    s = "0" & TransAdForSearch(instring) & "01"
    Send s
 End Sub
 Private Sub Send(Xstring As String)    '发送子程序
    Dim OutData() As Byte              '发送数组
    Dim length As Integer, i As Integer
 If RcvFinFlag = True Then
    SaveString = Xstring              '***保存发送字符串,为出错重发做准备
    RcvLen = -1                       '接收数组长度初始化
    RcvFinFlag = False
    length = Len(Xstring)
    ReDim Preserve OutData(0 To length + 1) As Byte
    OutData(0) = &H2                    'STX
    For i = 1 To length
       OutData(i) = AscB(Mid(Xstring, i, 1))
    Next i
    OutData(length + 1) = &H3               'ETX
    Call FcSCheck(OutData)                  '加校验和
    Form1.MSComm1.Output = OutData
    Call OutTxt(OutData)              '显示数据
    Form1.Timer2.Enabled = True          '准备接收，打开定时器
Else
    MsgBox "前一个命令尚未执行完", vbExclamation, "操作提示"
End If
End Sub
Private Function Exchange(str1 As String) As String      '高低字节换位
    Dim i As Integer
    Dim Temp(3) As String
    Dim str2 As String
    str2 = ""
     Temp(0) = Mid(str1, 3, 1)
     Temp(1) = Mid(str1, 4, 1)
     Temp(2) = Mid(str1, 1, 1)
     Temp(3) = Mid(str1, 2, 1)
     For i = 0 To 3
     str2 = str2 & Temp(i)
     Next
     Exchange = str2
   End Function
 Private Function TransAd(Component As String) As String          ' Component地址转换(5位格式)
    Dim Temp(4) As String
    Dim i As Integer, XY As Integer
    Dim str1 As String
    Dim value As Integer
    For i = 0 To 4
    Temp(i) = Mid(Component, i + 1, 1)
    Next
    value = Val(Temp(1) & Temp(2) & Temp(3) & Temp(4))
  Select Case Temp(0)
  Case "D"
     value = 2 * value + &H1000                      'D0 ,1 0 0 0
     str1 = Hex(value)
     TransAd = str1
  Case "M"
     value = value + &H800                            'M0, 0 0 0 8
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case "Y"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "输入错误,将改变Y" & value + 2 & "的值!", vbInformation
     XY = Fix(value / 10) * 2
     value = value + &H500 - XY                         'Y0, 0 0 0 5
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case "X"
    If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "输入错误,将改变X" & value + 2 & "的值!", vbInformation
     XY = Fix(value / 10) * 2
     value = value + &H400 - XY                         'X0, 0 0 0 4
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case Else
     MsgBox "没有定义!"
  End Select
End Function
Private Function TransAdForSearch(Component As String) As String 'Bit Component查询地址转换(5位格式)
    Dim Temp(4) As String
    Dim i As Integer, j As Integer
    Dim str1 As String
    Dim value As Integer
    For i = 0 To 4
    Temp(i) = Mid(Component, i + 1, 1)
    Next
    value = Val(Temp(1) & Temp(2) & Temp(3) & Temp(4))
  Select Case Temp(0)
   Case "M"
      value = Fix(value / 8)
      value = value + &H100
      str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
      TransAdForSearch = str1
   Case "Y"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "输入错误,将查询Y" & value - 8 & "的值!", vbInformation
      value = Fix(value / 10)
      value = value + &HA0
      str1 = Hex(value)
      j = Len(str1)
      str1 = String(4 - j, "0") & str1
      TransAdForSearch = str1
   Case "X"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "输入错误,将查询X" & value - 8 & "的值!", vbInformation
      value = Fix(value / 10)
      value = value + &H80
      str1 = Hex(value)
      j = Len(str1)
      str1 = String(4 - j, "0") & str1
      TransAdForSearch = str1
   Case Else
    MsgBox "没有定义!"
    End Select
 End Function
   Public Function OutTxt(ss() As Byte) '发送记录
      Dim i As Integer
      Dim vv As String
      Dim str1 As String
        For i = LBound(ss) To UBound(ss)
        str1 = IIf(Len(Hex(ss(i))) = 1, "0" & Hex(ss(i)), Hex(ss(i)))
        vv = vv & str1 & " "
        Next i
        Form1.Text6.Text = Form1.Text6.Text & "发送 " & vv & vbCrLf
     End Function
      Public Function InTxt(ss() As Byte) '接收记录
       Dim i As Integer
       Dim vv As String
       Dim str1 As String
        For i = LBound(ss) To UBound(ss)
       str1 = IIf(Len(Hex(ss(i))) = 1, "0" & Hex(ss(i)), Hex(ss(i)))
        vv = vv & str1 & " "
        Next i
        Form1.Text6.Text = Form1.Text6.Text & "接收 " & vv & vbCrLf
     End Function
Private Sub FcSCheck(xData() As Byte)             '数组求校验和
    Dim BufLen As Integer, Buf As String
    Dim i As Integer
    Dim CheckSum As Long
    BufLen = UBound(xData)
    CheckSum = 0
    For i = LBound(xData) + 1 To BufLen
       CheckSum = (CheckSum + xData(i)) And &HFF
    Next i
    Buf = IIf(Len(Hex(CheckSum)) = 1, "0" & Hex(CheckSum), Hex(CheckSum))
    ReDim Preserve xData(BufLen + 2) As Byte
    xData(BufLen + 1) = Asc(Mid(Buf, 1, 1))
    xData(BufLen + 2) = Asc(Mid(Buf, 2, 1))
End Sub
Public Sub ErrorHandle()                 ' 通信错误处理子程序
    If Num >= 0 And Num < 2 Then         '***重发次数2
        Num = Num + 1
        RcvFinFlag = True
        Call Send(SaveString)
        Exit Sub
    Else
        Form1.Timer2.Enabled = False
        MsgBox "请检查硬件连接及报文设置", vbExclamation, "通信超时或通信过程出错"
        Num = 0
        RcvFinFlag = True
        Exit Sub
     End If
 End Sub
       Public Function RcvDataChk(cData() As Byte) As Boolean     '校验子程序
          Dim CheckFlag As Boolean
          CheckFlag = False
          Dim i As Integer, EndNo As Integer
          For i = 0 To UBound(cData)
          If cData(i) = &H3 Then                    '"ETX"
             EndNo = i
             Exit For
          End If
          Next i
          Dim dData() As Byte
          ReDim Preserve dData(0 To EndNo) As Byte
          For i = 0 To EndNo
          dData(i) = cData(i)
          Next i
          Call FcSCheck(dData)
          If dData(EndNo + 1) = cData(EndNo + 1) And dData(EndNo + 2) = cData(EndNo + 2) Then
          CheckFlag = True
          End If
          RcvDataChk = CheckFlag
        End Function
        Public Function RcvDataDisplay(xRcv() As Byte) As String    '显示子函数
           Dim str1 As String
           Dim i As Integer
           str1 = ""
          If xRcv(0) = &H2 Then                           '"STX"
             For i = 1 To UBound(xRcv)
             If xRcv(i) <> &H3 Then                       '"ETX"
             str1 = str1 & Chr(xRcv(i))
             Else
             Exit For
             End If
             Next i
            Select Case Len(str1)
             Case 4
             RcvDataDisplay = Exchange(str1)
             Case 8
             RcvDataDisplay = Exchange(Mid(str1, 1, 4)) & Exchange(Mid(str1, 5, 4))       '十六进制
            End Select
            'Form1.txtview = Format((Val("&h" & ShwTemp) / 10), "# #0.0")  '十进制
           End If
        End Function
        Public Sub BitDisplay(xRcv() As Byte)    '显示子函数
           Dim str1 As String
           Dim i As Integer, j As Integer
           Dim value As Integer
           Dim Binary(7) As Byte
            str1 = Chr(xRcv(1))
            str1 = str1 & Chr(xRcv(2))
               value = Val("&h" & str1)
               j = 128
               For i = 7 To 0 Step -1
               Binary(i) = Fix(value / j)
               value = value Mod j
               j = j / 2
               Next i
            If Form1.Combo1.Text = "M" Then
               value = Val(Form1.Text5.Text)
               i = 0
                 For j = 0 To 7
                  If value Mod 8 = 0 Then Exit For
                  i = i + 1
                  value = value - 1
                 Next
            Else
                i = Val(Mid(Form1.Text5.Text, 4, 1))
                If i = 8 Then i = 0
                If i = 9 Then i = 1
            End If
            If Binary(i) = 1 Then
                  Form1.Shape1.FillColor = vbRed
                Else
                  Form1.Shape1.FillColor = vbBlack
            End If
        End Sub
        Public Sub ConFirm(CodeByte As Byte)
            Dim OutData(0) As Byte              '发送数组
            OutData(0) = CodeByte
            Form1.MSComm1.Output = OutData
            Call OutTxt(OutData)              '显示数据
        End Sub