csiemenscomm.cls

与西门子PLC通讯的程序,经工业现场测试没有问题

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cSiemensCOMM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' @@@@@@@@  调用方法  @@@@@@@@

' 定义通讯串口号            setComPort
' 定义通讯串口设置          setComSet
' 实例化MSCOMM控件          setMSCOMMOCX
' 实例化Timer控件           setTimerOCX
' 初始化                    Initialization
' 开始通讯                  DoCommunication
' 在需要写数据的时候设置    setWriteOrder
' 关闭时销毁所有实例，调用  Termination


Private WithEvents priCOMM          As MSComm
Attribute priCOMM.VB_VarHelpID = -1
Private WithEvents priTMRERR        As Timer
Attribute priTMRERR.VB_VarHelpID = -1

Private priCOMPort                  As Integer
Private priCOMSettings              As String
Private priRecBuf                   As String
Private priReadOrder(1 To 6)        As String
Private priTempOrder                As String
Private priThisLoopTime             As Long
Private priLastLoopTime             As Long
Private priACPosition               As Long
Private priRealData(3)              As Double                       '采集到的数据，最多一次有4个



' @ 返回采集到的数据信息,ByRef是以地址形式赋值,lArrData()由调用者提供,并在此Class中对其操作.
Public Event GetRealTimeData(ByRef lArrData() As Long, ByVal lPosition As Integer)



' @ 定义本类的属性

Public Property Let setComPort(ByVal lNewValue As Integer)          '定义通讯串口号
    priCOMPort = lNewValue
End Property

Public Property Let setComSet(ByVal lNewValue As String)            '定义通讯串口设置
    priCOMSettings = lNewValue
End Property

Public Property Let setMSCOMMOCX(ByRef lMSCOMM As MSComm)           '实例化MSComm控件
    Set priCOMM = lMSCOMM
End Property

Public Property Let setTimerOCX(ByRef lTimer As Timer)              '实例化Timer控件
    Set priTMRERR = lTimer
End Property

Public Property Let setWriteOrder(ByVal lNewValue As String)        '定义写命令
    
    On Local Error GoTo ErrOPR
        '检查写信息是否合法
        If CheckBCC(lNewValue) Then         '注意要在写通讯结束之后，将这些设置恢复到正常的状态
            priReadOrder(6) = lNewValue     '将写命令赋给第6条命令集合
        End If
    Exit Property
ErrOPR:
    
End Property


Public Sub Initialization()             ' @ 初始化
    
    On Error GoTo ErrOPR
        
        priTMRERR.Interval = 2000
        priTMRERR.Enabled = True
        If priCOMM.PortOpen = True Then priCOMM.PortOpen = False
            priCOMM.CommPort = priCOMPort
        If priCOMM.PortOpen = False Then priCOMM.PortOpen = True
        priCOMM.Settings = priCOMSettings
        priCOMM.InputLen = 0
        priCOMM.RThreshold = 1
        priCOMM.InputMode = comInputModeText
        Call GetCOMString   '得到读命令字符串
    
ErrOPR:
    
    
End Sub

Public Function Termination()           ' @ 关闭时，销毁所有实例
    
    priTMRERR.Enabled = False
    If priCOMM.PortOpen = True Then priCOMM.PortOpen = False
    Set priTMRERR = Nothing
    Set priCOMM = Nothing
    
    
End Function


Public Sub DoCommunication()
    
    Call SendCOMString(1)
    
End Sub

Private Sub GetCOMString()              '计算通讯命令字符串（固定的）
    
    On Local Error GoTo ErrOPR
        priReadOrder(1) = "g" & Chr$(5) & "02080003E800000000000000000071G"
        priReadOrder(2) = "g" & Chr$(5) & "02080003F00000000000000000007AG"
        priReadOrder(3) = "g" & Chr$(5) & "02080003F800000000000000000072G"
        priReadOrder(4) = "g" & Chr$(5) & "02080004000000000000000000000BG"
        priReadOrder(5) = "g" & Chr$(5) & "020800040800000000000000000003G"
        priTempOrder = "g" & Chr$(5) & "02080005DC0000000000000000000DG"        '临时命令字符串读取VB1500的8个字节数据
        priReadOrder(6) = priTempOrder
    Exit Sub
ErrOPR:
    
End Sub

Private Sub SendCOMString(ByVal lPosition As Integer)   '仅仅是发送标志位对应的命令
    
    On Local Error GoTo ErrOPR
        Sleep 5                                         '延时5 ms
        priCOMM.Output = priReadOrder(lPosition)        '向串口发送命令
    Exit Sub
ErrOPR:
    
End Sub

Private Sub COMReset()                                  '通讯出错时对通讯进行复位
    
    On Local Error GoTo ErrOPR
        Dim sTP
        sTP = priCOMM.Input                             '清空接收缓冲区
        If priACPosition = 6 Then                       '对通讯标志位进行处理，使之达到下一个通讯位
            priACPosition = 0
        End If
        priACPosition = priACPosition + 1
        priRecBuf = ""                                  '清除 priRecbuf 接收字符串
        Call SendCOMString(priACPosition)               '发送下一条通讯命令
    Exit Sub
ErrOPR:
        
End Sub

Private Sub CodeToData(ByVal lCode As String, ByVal lPosition As Integer)      '将数据码翻译成数据，然后触发 GetDATA 事件
    
    On Local Error GoTo ErrOPR
        '数据位只有16个字节
        '判断数据码是否合法，不合法就不触发 GetDATA 事件
        If Not IsNumeric("&H" & Left(lCode, 8)) Or Not IsNumeric("&H" & Right(lCode, 8)) Then
            Exit Sub        '任何一段不符合就退出此过程
        End If
        Dim tData(8) As Long
        Select Case lPosition
            Case 1, 3
            tData(0) = CLng("&H" & Mid(lCode, 1, 4))
            tData(1) = CLng("&H" & Mid(lCode, 5, 4))
            tData(2) = CLng("&H" & Mid(lCode, 9, 4))
            tData(3) = CLng("&H" & Mid(lCode, 13, 4))
            Case 2
            tData(0) = CLng("&H" & Mid(lCode, 1, 8))
            tData(1) = CLng("&H" & Mid(lCode, 9, 8))
            tData(2) = 0
            tData(3) = 0
            Case 5
            tData(0) = CLng("&H" & Mid(lCode, 1, 4))    'VW1032
            tData(1) = CLng("&H" & Mid(lCode, 5, 2))    'VB1034
            tData(2) = 0
            tData(3) = 0
            Case 4
            tData(0) = CLng("&H" & Mid(lCode, 1, 4))    'VW1024   K   49
            tData(1) = CLng("&H" & Mid(lCode, 5, 2))    'VB1026   SV_PRSUB
            tData(2) = CLng("&H" & Mid(lCode, 7, 2))    'VB1028   Status
            tData(3) = CLng("&H" & Mid(lCode, 9, 2))    'VB1029   QB0
            Case Else
            tData(0) = 0
            tData(1) = 0
            tData(2) = 0
            tData(3) = 0
        End Select
        RaiseEvent GetRealTimeData(tData(), lPosition)
        Exit Sub
ErrOPR:
    
End Sub

Private Function CheckBCC(ByVal lOrder As String) As Boolean    '检验命令的合法性

    On Local Error GoTo ErrOPR
        Dim s$, oldBCC%, i%, j%
        CheckBCC = False
        If Len(lOrder) < 33 Then
            Exit Function                               '长度不够
        End If
        s = Left(lOrder, Len(lOrder) - 1)               '去掉结束 G
        s = Right(s, Len(s) - 1)                        '去掉开始 g
        oldBCC = CInt("&H" & Right(s, 2))               '取BCC部分
        s = Left(s, Len(s) - 2)                         '去掉BCC部分，只剩下Byte1～Byte29

        For i = 1 To Len(s)
            j = j Xor Asc(Mid(s, i, 1))
        Next
        If oldBCC = j Then CheckBCC = True
    Exit Function
ErrOPR:
    CheckBCC = False
    
End Function

Private Sub priCOMM_OnComm()                            'MsComm控件的OnComm事件

    On Local Error GoTo ErrOPR
        Select Case priCOMM.CommEvent
            Case comEvReceive
            priRecBuf = priRecBuf & priCOMM.Input
            Case Else
        End Select
        '************************* 处理接收到的信息 *******************************
        If InStr(priRecBuf, Chr$(&H1A)) Then            '收到正确的信号
            Dim POS%                                    '得到信息中"g"的位置
            '------------------ 完成对 Siemens PLC 参数的修改 ------------------
            If InStr(priRecBuf, Chr$(2)) Then
                priReadOrder(6) = priTempOrder
                priRecBuf = ""
                priThisLoopTime = GetCurrentTime()      '得到当前的时间 ms
                priACPosition = 1
                Call SendCOMString(1)
                Exit Sub                                '直接结束 OnComm 事件
            End If
        
            '------------------ 正常读取信息时的操作 ------------------
            priThisLoopTime = GetCurrentTime()          '得到当前的时间 ms
            If Len(priRecBuf) < 21 Then                 '数据串太短认为此次通讯失败
                Call COMReset                           '复位通讯
                Exit Sub                                '直接结束 OnComm 事件
            End If
            POS = InStr(priRecBuf, "g")
            priRecBuf = Mid(priRecBuf, POS + 2, 16)     '获得数据位
            Call CodeToData(priRecBuf, priACPosition)   '数据处理
            If priACPosition = 6 Then                   '对通讯标志位进行处理，使之达到下一个通讯位
                priACPosition = 0
            End If
            priACPosition = priACPosition + 1
            priRecBuf = ""                              '清除 priRecbuf 接收字符串
            Call SendCOMString(priACPosition)           '发送下一条通讯命令
            Exit Sub                                    '直接结束 OnComm 事件
        End If
    Exit Sub
ErrOPR:
    

End Sub

Private Sub priTMRERR_Timer()                           '处理通讯延时时间的 Timer 定时器

        If priThisLoopTime = priLastLoopTime Then       '通讯超时
            Call COMReset                               '通讯复位（下一次）
        End If
        priLastLoopTime = priThisLoopTime
        

End Sub