mdl3.bas

此为交通信号机

Attribute VB_Name = "Mdl3"
Option Explicit

Public Function OrgnizeDataToPlc(FirstTimes As Boolean, HalfTable As Integer) As String
       Dim Mr As Integer
       Dim Mc As Integer
       Dim String4 As String
       Dim String2 As String                        'String4 4个字符，String2 两个字符
       Dim ValString4 As Long
       Dim ValString2 As Long
       Dim HexString4 As String
       Dim HexString2 As String
       Dim BinString4 As String
       Dim BinString2 As String
       Dim HexString4Reverted As String
       Dim HexString2Reverted As String
       Dim Char As String
       
       OrgnizeDataToPlc = ""
       BinString4 = ""
       
       For Mc = (1 + HalfTable * 20) To (20 + HalfTable * 20)
        For Mr = 1 To 32
            Char = Right(Str(DataMatrix(Mr, Mc)), 1)
            If FirstTimes = True Then
                If Char = "2" Then
                    Char = "1"
                End If
            Else
                If Char = "2" Then
                    Char = "0"
                End If
            End If
            BinString4 = Char + BinString4
        Next
        For Mr = 33 To 40
            Char = Right(Str(DataMatrix(Mr, Mc)), 1)
            If FirstTimes = True Then
                If Char = "2" Then
                    Char = "1"
                End If
            Else
                If Char = "2" Then
                    Char = "0"
                End If
            End If
            BinString2 = Char + BinString2
        Next
        HexString4 = Mdl3.BinStringToHexString(BinString4)
        HexString2 = Mdl3.BinStringToHexString(BinString2)
        
        '调整字符排列顺序
        HexString4Reverted = Mid(HexString4, 5, 1) + Mid(HexString4, 6, 1) + Mid(HexString4, 7, 1) + Mid(HexString4, 8, 1) + Mid(HexString4, 1, 1) + Mid(HexString4, 2, 1) + Mid(HexString4, 3, 1) + Mid(HexString4, 4, 1)
        HexString2Reverted = Mid(HexString2, 1, 1) + Mid(HexString2, 2, 1)
        OrgnizeDataToPlc = OrgnizeDataToPlc + HexString4Reverted + HexString2Reverted + "00"
     
     
     Next
        
       
End Function

Public Function BinStringToHexString(BinString As String) As String
        Dim Str1 As String
        Dim Str2 As String
        Dim i As Integer
        BinStringToHexString = ""
        For i = 1 To Len(BinString) / 4
            Str1 = Mid(BinString, (i - 1) * 4 + 1, 4)
            
            Select Case Str1
                Case "0000"
                    Str2 = "0"
                Case "0001"
                    Str2 = "1"
                Case "0010"
                    Str2 = "2"
                Case "0011"
                    Str2 = "3"
                Case "0100"
                    Str2 = "4"
                Case "0101"
                    Str2 = "5"
                Case "0110"
                    Str2 = "6"
                Case "0111"
                    Str2 = "7"
                Case "1000"
                    Str2 = "8"
                Case "1001"
                    Str2 = "9"
                Case "1010"
                    Str2 = "A"
                Case "1011"
                    Str2 = "B"
                Case "1100"
                    Str2 = "C"
                Case "1101"
                    Str2 = "D"
                Case "1110"
                    Str2 = "E"
                Case "1111"
                    Str2 = "F"
             End Select
             BinStringToHexString = BinStringToHexString + Str2
         Next i
End Function
Public Function WriteSchemeToPlc(AddStart As String, WriteBytes As String, outstring As String) As Boolean
         Dim instring As String
         Dim i As Integer
         Dim Sum As Integer
         Dim time1
         Dim WriteNums As String
         WriteNums = Hex(Val(WriteBytes))
        '将地址调整为4位
         If Len(AddStart) <> 8 Then
            Select Case Len(AddStart)
               Case 1
                   AddStart = "0000000" + AddStart
               Case 2
                   AddStart = "000000" + AddStart
               Case 3
                   AddStart = "00000" + AddStart
                Case 4
                   AddStart = "0000" + AddStart
                 Case 5
                   AddStart = "000" + AddStart
                 Case 6
                   AddStart = "00" + AddStart
                 Case 7
                   AddStart = "0" + AddStart
            End Select
         End If
         
          '调整位数
            
            If Len(WriteNums) = 1 Then
              WriteNums = "0" + WriteNums
            End If
                 
          
          '地址和校验
           Sum = &H31                          'CMD 1
           For i = 1 To 4
           Sum = Sum + Asc(Mid(AddStart, i, 1))
           Next i
         
           '数量和校验
            For i = 1 To 2
               Sum = Sum + Asc(Mid(WriteNums, i, 1))
           Next
         
           '数据和校验
             
            For i = 1 To 2 * Val(WriteBytes)
                Sum = Sum + Asc(Mid(outstring, i, 1))
            Next i
           Sum = Sum + 3      '和校验完毕
           
           
           '发送数据
          
           FrmMain.MSComm1.PortOpen = True
           FrmMain.MSComm1.Output = Chr(&H2) + Chr(&H31)   'STX  CMD 1
           FrmMain.MSComm1.Output = AddStart
           FrmMain.MSComm1.Output = WriteNums
           FrmMain.MSComm1.Output = outstring
           FrmMain.MSComm1.Output = Chr(3)            'ETX
           FrmMain.MSComm1.Output = Right(Hex(Sum), 2)        'SUM


           '接收应答：
           time1 = Timer
           Do
           DoEvents
           Loop Until FrmMain.MSComm1.InBufferCount >= 1 Or (Timer - time1) > 10
           instring = FrmMain.MSComm1.Input
           If (Timer - time1) > 10 Then
               MsgBox "PLC没有响应！"
               WriteSchemeToPlc = False
           Else
               If instring = Chr(6) Then
                  WriteSchemeToPlc = True       'MsgBox "数据传输成功！"
               Else
                 If instring = Chr(&H15) Then
                   WriteSchemeToPlc = False    'MsgBox "数据传输失败！请重试"
                 Else
                 End If
               End If
            End If
           FrmMain.MSComm1.PortOpen = False
          
end1:
End Function