opcgroupclass.cls

opc 通讯 册测试通讯OPC使用 客户端/服务端

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "OPCGroupClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim OPCGroupName As String
Dim OPCGroupKey As String
Dim WithEvents OPCGroupObj As OPCGroup
Attribute OPCGroupObj.VB_VarHelpID = -1
Dim OPCGroupItems As New Collection
Dim GroupIndex As Integer

Sub SetOPCGroup(ByVal OPCGroupObject As OPCGroup, ByVal GroupName As String, ByVal GroupKey As String, ByVal GroupIndx As Integer)
    Dim StoreName As String
    Dim StoreKey As String
    
    Set OPCGroupObj = OPCGroupObject
    StoreName = GroupName
    OPCGroupName = StoreName
    
    StoreKey = GroupKey
    OPCGroupKey = StoreKey
    
    GroupIndex = GroupIndx
    OPCGroupObj.IsSubscribed = True
   
End Sub

Function GetGroupName()
    GetGroupName = OPCGroupName
End Function

Function GetGroupKey()
    GetGroupKey = OPCGroupKey
End Function

Function GetGroupIndex()
    GetGroupIndex = GroupIndex
End Function

Function GetOPCGroupItemsCollection()
    Set GetOPCGroupItemsCollection = OPCGroupItems
End Function

Function SetGroupActiveState(ByVal ActiveState As Integer)
    On Error GoTo ShowOPCGroupActiveError
    OPCGroupObj.IsActive = ActiveState
    SetGroupActiveState = True
    GoTo SkipGroupActiveError
ShowOPCGroupActiveError:
    Call DisplayOPC_COM_ErrorValue("Group Active State", Err.Number)
    SetGroupActiveState = False
SkipGroupActiveError:
    
End Function

Function GetGroupActiveState(ByRef ActiveState As Boolean)
    On Error GoTo ShowOPCGetGroupActiveError
    ActiveState = OPCGroupObj.IsActive
    GetGroupActiveState = True
    GoTo SkipGetGroupActiveError
ShowOPCGetGroupActiveError:
    Call DisplayOPC_COM_ErrorValue("Get Group Active State", Err.Number)
    GetGroupActiveState = False
SkipGetGroupActiveError:
    
End Function

Function SetGroupDeadBand(ByVal DeadBand As Single)
    On Error GoTo ShowOPCSetGroupDeadBandError
    
    OPCGroupObj.DeadBand = DeadBand
    SetGroupDeadBand = True
    GoTo SkipSetGroupDeadBandError

ShowOPCSetGroupDeadBandError:
    Call DisplayOPC_COM_ErrorValue("Set Group Dead Band", Err.Number)
    SetGroupDeadBand = False
SkipSetGroupDeadBandError:
End Function

Function GetGroupDeadBand(ByRef DeadBand As Single)
    On Error GoTo ShowOPCGetGroupDeadBandError
    
    DeadBand = OPCGroupObj.DeadBand
    GetGroupDeadBand = True
    GoTo SkipGetGroupDeadBandError

ShowOPCGetGroupDeadBandError:
    Call DisplayOPC_COM_ErrorValue("Get Group Dead Band", Err.Number)
    GetGroupDeadBand = False
SkipGetGroupDeadBandError:
End Function

Function SetGroupUpdateRate(ByVal UpdateRate As Long)
    On Error GoTo ShowOPCSetGroupUdateRateError
    
    OPCGroupObj.UpdateRate = UpdateRate
    SetGroupUpdateRate = True
    GoTo SkipSetGroupUdateRateError

ShowOPCSetGroupUdateRateError:
    Call DisplayOPC_COM_ErrorValue("Set Group Update Rate", Err.Number)
    SetGroupUpdateRate = False
SkipSetGroupUdateRateError:
End Function

Function GetGroupUpdateRate(ByRef UpdateRate As Long)
    'Set error handling for OPC Function
    On Error GoTo ShowOPCGetGroupUdateRateError
    
    UpdateRate = OPCGroupObj.UpdateRate
    GetGroupUpdateRate = True
    GoTo SkipGetGroupUdateRateError

ShowOPCGetGroupUdateRateError:
    Call DisplayOPC_COM_ErrorValue("Get Group Update Rate", Err.Number)
    GetGroupUpdateRate = False
SkipGetGroupUdateRateError:
End Function

Function SetOPCItemsDefaultDataType(ByVal DataType As Integer)
    On Error GoTo ShowOPCItemsDefaultDataTypeError
    
    OPCGroupObj.OPCItems.DefaultRequestedDataType = DataType
    SetOPCItemsDefaultDataType = True
    GoTo SkipOPCItemsDefaultDataTypeError

ShowOPCItemsDefaultDataTypeError:
    Call DisplayOPC_COM_ErrorValue("Set OPC Item Default Data Type", Err.Number)
    SetOPCItemsDefaultDataType = False
SkipOPCItemsDefaultDataTypeError:
End Function

' This function gets the default item data type of a group
'
Function GetOPCItemsDefaultDataType(ByRef DataType As Integer)
    'Set error handling for OPC Function
    On Error GoTo ShowOPCGetItemsDefaultDataTypeError
    
    DataType = OPCGroupObj.OPCItems.DefaultRequestedDataType
    GetOPCItemsDefaultDataType = True
    GoTo SkipOPCGetItemsDefaultDataTypeError

ShowOPCGetItemsDefaultDataTypeError:
    Call DisplayOPC_COM_ErrorValue("Get OPC Item Default Data Type", Err.Number)
    GetOPCItemsDefaultDataType = False
SkipOPCGetItemsDefaultDataTypeError:
End Function

Function SetOPCItemsDefaultActive(ByVal ActiveState As Integer)
    On Error GoTo ShowOPCItemsDefaultActiveError
    
    OPCGroupObj.OPCItems.DefaultIsActive = ActiveState
    SetOPCItemsDefaultActive = True
    GoTo SkipOPCItemsDefaultActiveError

ShowOPCItemsDefaultActiveError:
    Call DisplayOPC_COM_ErrorValue("Set OPC Item Default Active State", Err.Number)
    SetOPCItemsDefaultActive = False
SkipOPCItemsDefaultActiveError:
End Function

Function GetOPCItemsDefaultActive(ByRef ActiveState As Integer)
    On Error GoTo ShowOPCGetItemsDefaultActiveError
    
    ActiveState = OPCGroupObj.OPCItems.DefaultIsActive
    GetOPCItemsDefaultActive = True
    GoTo SkipOPCGetItemsDefaultActiveError

ShowOPCGetItemsDefaultActiveError:
    Call DisplayOPC_COM_ErrorValue("Get OPC Item Default Active State", Err.Number)
    GetOPCItemsDefaultActive = False
SkipOPCGetItemsDefaultActiveError:
End Function

Function AddOPCItem(ByVal OPCItemID As String, ByVal DataType As Integer, ByVal ActiveState As Integer, ByRef ItemKey As String)
    
    On Error GoTo ShowOPCItemAddError
    
    Dim ItemToAdd As New OPCItemClass
    Dim NewItem As OPCItem
    Dim ItemIndex As Integer
    Dim TmpOPCItemID As String
    SetOPCItemsDefaultActive (ActiveState)
    SetOPCItemsDefaultDataType (DataType)
    TmpOPCItemID = OPCItemID
    ItemIndex = FindNextItemNumber
    Set NewItem = OPCGroupObj.OPCItems.AddItem(OPCItemID, ItemIndex)
        
    If Not NewItem Is Nothing Then
        ItemToAdd.SetOPCItem NewItem, TmpOPCItemID, ItemIndex, DataType
        ItemKey = "Item" + Str(ItemIndex)
        With OPCGroupItems
            .Add ItemToAdd, Str(ItemIndex)
        End With
    Else
        AddOPCItem = False ' Signify a failure of this function
        Exit Function
    End If
        
    AddOPCItem = True
    
    GoTo SkipAddItemError

ShowOPCItemAddError:
    Call DisplayOPC_COM_ErrorValue("Add Item", Err.Number)
    AddOPCItem = False
SkipAddItemError:
    
End Function
'
Function RemoveOPCItem(ItemKey As String, ByRef Error As Long)
    On Error GoTo ShowOPCItemRemoveError
            
    Dim OPCItemToRemove As OPCItemClass
    Dim ServerHandles(1) As Long
    Dim Errors() As Long
    Dim Count As Long
    
    Set OPCItemToRemove = OPCGroupItems.Item(Mid(ItemKey, InStr(ItemKey, " ")))
    ServerHandles(1) = OPCItemToRemove.GetItemServerHandle
    Count = 1
    OPCGroupObj.OPCItems.Remove Count, ServerHandles, Errors
    
    If Errors(1) <> 0 Then
        Error = Err.Number = Errors(1)
        GoTo ShowOPCItemRemoveError
    End If
    
    OPCGroupItems.Remove (Mid(ItemKey, InStr(ItemKey, " ")))
        
    RemoveOPCItem = True
    GoTo SkipRemoveItemError

ShowOPCItemRemoveError:
    Call DisplayOPC_COM_ErrorValue("Remove Item", Err.Number)
    RemoveOPCItem = False
SkipRemoveItemError:
End Function

Private Function FindNextItemNumber()
    On Error GoTo FoundNextItemNumber
    
    Dim i As Integer
    Dim ItemNum As Integer
    
    ItemNum = 1
    
    With OPCGroupItems
        For i = 1 To .Count
            ItemNum = i
            .Item (Str(i))
        Next i
        If .Count <> 0 Then
            FindNextItemNumber = i
        Else
            FindNextItemNumber = 1 ' No count return the first 1
        End If
    End With
    
    GoTo NewIndex
    
FoundNextItemNumber:
    FindNextItemNumber = ItemNum
NewIndex:
End Function


Function ValidateOPCItem(ByVal OPCItemID As String, ByVal DataType As Integer, ByVal ActiveState As Integer, ByRef Error As Long)
         
    Dim Errors() As Long
    Dim ItemCount As Long
    Dim OPCItemIDs(1) As String
    Dim RequestedDataTypes(1) As Integer
    On Error GoTo ShowOPCItemValidateError
    
    SetOPCItemsDefaultActive (ActiveState)
    SetOPCItemsDefaultDataType (DataType)
    
    OPCItemIDs(1) = OPCItemID
    RequestedDataTypes(1) = DataType
    ItemCount = 1
    
    OPCGroupObj.OPCItems.Validate ItemCount, OPCItemIDs, Errors, RequestedDataTypes
    If Errors(1) <> 0 Then
       Error = Errors(1)
       ValidateOPCItem = False
       GoTo SkipValidateItemError
    End If
    
    ValidateOPCItem = True
    GoTo SkipValidateItemError

ShowOPCItemValidateError:
    Call DisplayOPC_COM_ErrorValue("Validate Item", Err.Number)
    ValidateOPCItem = False
SkipValidateItemError:
    
End Function

Function AsyncWriteOPCItem(ObjectToWrite As OPCItemClass, ValueToWrite As Variant)
    
    Dim ServerHandles(1) As Long
    Dim Errors() As Long
    Dim Count As Long
    Dim TransactionID As Long
    Dim CancelID As Long
    Dim Values(1) As Variant
    On Error GoTo ShowOPCItemWriteError
    Count = 1
    ServerHandles(1) = ObjectToWrite.GetItemServerHandle
    TransactionID = 1
    Values(1) = ValueToWrite
    OPCGroupObj.AsyncWrite Count, ServerHandles, Values, Errors, TransactionID, CancelID
    
    AsyncWriteOPCItem = True
GoTo SkipItemWriteError

ShowOPCItemWriteError:
    Call DisplayOPC_COM_ErrorValue("Write Item", Err.Number)
    AsyncWriteOPCItem = False
SkipItemWriteError:

End Function
Sub DisplayOPC_COM_ErrorValue(OPC_Function As String, ErrorCode As Long)
    Dim Response
    Dim ErrorDisplay As String
    ErrorDisplay = "The OPC function '" + OPC_Function + "' has returned an error of " + Str(ErrorCode) + " or Hex 0x" + Hex(ErrorCode)
    Response = MsgBox(ErrorDisplay, vbOKOnly, "OPC Function Error")
End Sub
Private Sub OPCGroupObj_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)
    On Error Resume Next
 
    Dim UpdateItem As OPCItemClass
    Dim i As Integer
    
    For i = 1 To NumItems
        Set UpdateItem = OPCGroupItems.Item(Str(ClientHandles(i)))
        If Not UpdateItem Is Nothing Then
            UpdateItem.UpdateOPCItemData ItemValues(i), Qualities(i), TimeStamps(i)
        End If
    Next i

End Sub

Private Sub OPCGroupObj_AsyncWriteComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, Errors() As Long)
    Dim UpdateItem As OPCItemClass
    Dim i As Integer
    
    For i = 1 To NumItems
        Set UpdateItem = OPCGroupItems.Item(Str(ClientHandles(i)))
        If Not UpdateItem Is Nothing Then
            If Errors(i) Then
                UpdateItem.SetItemQuality (0)
            End If
        End If
    Next i
End Sub