clsplcs7.cls

西门子PLC和VB通过自由协议通讯程序（是一个类模块

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

'保持属性值的局部变量
Private mvarCommSendData As Variant  '局部复制
Private mbytComSendDataArry(0 To 10, 0 To 7) As Byte  '通讯发送队列
Private mintComSendDataIndex As Integer '通讯发送队列指针
Private mblnFixStatus(0 To 47) As Boolean '设备状态
Private mintOldFixStatus(0 To 47) As Integer
Private mintNewFixStatus(0 To 47) As Integer
Private mintFixStatus(0 To 5) As Integer  '设备状态
Private mintMaxComOverTimeNum As Integer
Private mintComOverTimeNum As Integer
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent StatusChange[(arg1, arg2, ... , argn)]
Public Event StatusChange(ByVal intFixIndex As Integer, ByVal blnFixStatus As Boolean)
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent ComOverTime[(arg1, arg2, ... , argn)]
Public Event ComOverTime()

Public Sub ClearComOverTime()
    mintComOverTimeNum = 0
End Sub

Public Sub WriteComOverTime()
    mintComOverTimeNum = mintComOverTimeNum + 1
    If mintComOverTimeNum >= mintMaxComOverTimeNum Then
        SetComSendData
        mintComOverTimeNum = 0
        RaiseEvent ComOverTime
    End If
End Sub

Public Sub StopFixing(ByVal intFixCode As Integer)
    Dim bytStartOrder(0 To 7) As Byte
    Dim bytNum As Byte, bytFix As Byte
    bytStartOrder(0) = 2
    For bytNum = 1 To 4
        bytStartOrder(bytNum) = 255
    Next bytNum
    bytStartOrder(5) = 0
    bytStartOrder(6) = 0
    If intFixCode > 0 And intFixCode < 33 Then
        bytNum = (intFixCode - 1) Mod 8
        bytFix = Fix(intFixCode / 8)
        bytStartOrder(bytFix + 1) = bytStartOrder(bytFix + 1) - 2 ^ bytFix
        bytStartOrder(7) = SetComDataSum(bytStartOrder())
        WriteComSendData bytStartOrder()
    End If
End Sub

Public Sub StartFixing(ByVal intFixCode As Integer)
    Dim bytStartOrder(0 To 7) As Byte
    Dim bytNum As Byte, bytFix As Byte
    bytStartOrder(0) = 2
    For bytNum = 1 To 6
        bytStartOrder(bytNum) = 0
    Next bytNum
    If intFixCode > 0 And intFixCode < 33 Then
        bytNum = (intFixCode - 1) Mod 8
        bytFix = Fix(intFixCode / 8)
        bytStartOrder(bytFix + 1) = bytStartOrder(bytFix + 1) + 2 ^ bytFix
        bytStartOrder(7) = SetComDataSum(bytStartOrder())
        WriteComSendData bytStartOrder()
    End If
End Sub

Public Sub ChangData(ByVal intDataAdr As Integer, ByVal intChangData As Integer)
    Dim bytChangOrder(0 To 7) As Byte
    Dim intI As Integer
    For intI = 0 To 6
        bytChangOrder(intI) = 0
    Next intI
    bytChangOrder(0) = 3
    bytChangOrder(4) = CByte(intDataAdr)
    bytChangOrder(5) = CByte(Fix(intChangData / 256))
    bytChangOrder(6) = CByte(intChangData Mod 256)
    bytChangOrder(7) = SetComDataSum(bytChangOrder())
    WriteComSendData bytChangOrder()
End Sub

Public Sub Init(ByVal intMaxComOverTimeNum As Integer)
    Dim intI As Integer
    mintMaxComOverTimeNum = intMaxComOverTimeNum
    mintComOverTimeNum = 0
    For intI = 0 To 5
        mintFixStatus(intI) = -1
    Next intI
    For intI = 0 To 47
        mblnFixStatus(intI) = False
        mintNewFixStatus(intI) = -1
        mintNewFixStatus(intI) = -1
    Next intI
    FormatSendDataArry
    SetComSendData
End Sub

Public Sub WriteRcvData(ByRef bytComRcvData() As Byte)
    Dim intI As Integer
    If CheckComDataSum(bytComRcvData) = True Then
        If bytComRcvData(0) = &HFF Then
            If SetFixStatus(bytComRcvData()) = True Then
                For intI = 0 To 47
                    If mintNewFixStatus(intI) <> mintOldFixStatus(intI) Then
                        RaiseEvent StatusChange(intI + 1, mblnFixStatus(intI))
                        mintOldFixStatus(intI) = mintNewFixStatus(intI)
                    End If
                Next intI
            End If
            SetComSendData
        End If
    End If
End Sub

Public Property Get FixStatus(ByVal intFixCode As Integer) As Boolean
    If intFixCode > 0 And intFixCode < 49 Then
        FixStatus = mblnFixStatus(intFixCode - 1)
    Else
        FixStatus = False
    End If
End Property

Public Property Get CommSendData() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.CommSendData
    CommSendData = mvarCommSendData
End Property

Private Sub FormatSendDataArry()
    Dim intI As Integer
    Dim bytFindComSend(0 To 7) As Byte
    For intI = 1 To 6
        bytFindComSend(intI) = 0
    Next intI
    bytFindComSend(7) = SetComDataSum(bytFindComSend())
    mintComSendDataIndex = 0
    WriteComSendData bytFindComSend()
End Sub

Private Sub SetComSendData()
    Dim bytComSendData(0 To 7) As Byte
    Dim intI As Integer
    mintComSendDataIndex = mintComSendDataIndex - 1
    If mintComSendDataIndex = -1 Then
        FormatSendDataArry
    End If
    For intI = 0 To 7
        bytComSendData(intI) = mbytComSendDataArry(mintComSendDataIndex, intI)
    Next intI
    mvarCommSendData = bytComSendData
End Sub

Private Sub WriteComSendData(ByRef bytComSendData() As Byte)
    Dim intI As Integer
    For intI = 0 To 7
        mbytComSendDataArry(mintComSendDataIndex, intI) = bytComSendData(intI)
    Next intI
    mintComSendDataIndex = mintComSendDataIndex + 1
End Sub

Private Function CheckComDataSum(ByRef bytComData() As Byte) As Boolean
    Dim intSum As Integer
    intSum = SetComDataSum(bytComData())
    If intSum = bytComData(7) Then
        CheckComDataSum = True
    Else
        CheckComDataSum = False
    End If
End Function

Private Function SetComDataSum(ByRef bytComData() As Byte) As Byte
    Dim intI As Integer
    Dim intSum As Integer
    intSum = 0
    For intI = 0 To 6
        intSum = intSum + bytComData(intI)
        intSum = intSum Mod 256
    Next intI
    SetComDataSum = intSum
End Function

Private Function SetFixStatus(ByRef bytFixStatus() As Byte) As Boolean
    Dim intLs As Integer
    Dim intI As Integer
    Dim blnChang As Boolean
    intLs = 1
    For intI = 0 To 7
        If (bytFixStatus(1) And intI) <> 0 Then
            mblnFixStatus(intI) = True
            mintNewFixStatus(intI) = 1
        Else
            mblnFixStatus(intI) = False
            mintNewFixStatus(intI) = 0
        End If
        If (bytFixStatus(2) And intI) <> 0 Then
            mblnFixStatus(intI + 8) = True
            mintNewFixStatus(intI + 8) = 1
        Else
            mblnFixStatus(intI + 8) = False
            mintNewFixStatus(intI + 8) = 0
        End If
        If (bytFixStatus(3) And intI) <> 0 Then
            mblnFixStatus(intI + 16) = True
            mintNewFixStatus(intI + 16) = 1
        Else
            mblnFixStatus(intI + 16) = False
            mintNewFixStatus(intI + 16) = 0
        End If
        If (bytFixStatus(4) And intI) <> 0 Then
            mblnFixStatus(intI + 24) = True
            mintNewFixStatus(intI + 24) = 1
        Else
            mblnFixStatus(intI + 24) = False
            mintNewFixStatus(intI + 24) = 0
        End If
        If (bytFixStatus(5) And intI) <> 0 Then
            mblnFixStatus(intI + 32) = True
            mintNewFixStatus(intI + 32) = 0
        Else
            mblnFixStatus(intI + 32) = False
            mintNewFixStatus(intI + 32) = 0
        End If
        If (bytFixStatus(6) And intI) <> 0 Then
            mblnFixStatus(intI + 40) = True
            mintNewFixStatus(intI + 40) = 1
        Else
            mblnFixStatus(intI + 40) = False
            mintNewFixStatus(intI + 40) = 0
        End If
    Next intI
    blnChang = False
    For intI = 0 To 5
        If mintFixStatus(intI) <> bytFixStatus(intI + 1) Then
            blnChang = True
        End If
    Next intI
    SetFixStatus = blnChang
End Function