opcserverclass.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 = "OPCServerClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
Option Base 1

Dim WithEvents OPCServerObj As OPCServer                        'opc 服务器
Attribute OPCServerObj.VB_VarHelpID = -1
Dim OPCServerName As String                                     '服务器名称
Dim OPCServerKey As String                                      '服务器关键字
Dim OPCServerIndex As Integer                                   '服务器索引

Dim ServerGroups As OPCGroups                                   '服务器下的组
Dim OPCServerGroups As New Collection

Public Event ServerShuttingDown(ByVal ServerKey As String)      'OPC服务器停止时发生

Sub GetOPCServerList(ByRef ServerList As Variant, Optional ByVal NodeName As Variant)
    Dim i As Integer
    On Error GoTo ShowOPCGetServersError
    ServerList = OPCServerObj.GetOPCServers(NodeName)           '返回数据为集合形式
    GoTo SkipOPCGetServersError
ShowOPCGetServersError:
    Call DisplayOPC_COM_ErrorValue("Get OPC Server List", Err.Number)
SkipOPCGetServersError:
End Sub

Function ConnectOPCServer(ServerName As String, ServerKey As String, ServerIndex As Integer, Optional ByVal NodeName As Variant)
    On Error GoTo ShowOPCConnectError
    Dim StoreName As String
    Dim StoreKey As String
    
    StoreName = ServerName
    OPCServerName = StoreName
    OPCServerIndex = ServerIndex
    StoreKey = ServerKey
    OPCServerKey = StoreKey
    OPCServerObj.Connect OPCServerName, NodeName                '连接到OPC服务器
    
    Set ServerGroups = OPCServerObj.OPCGroups
    SetDefaultGroupIsActive (True)
    SetDefaultGroupUpdateRate (100)
    SetDefaultGroupDeadBand (0)
    ConnectOPCServer = True
    GoTo SkipOPCConnectError
    
ShowOPCConnectError:
    Call DisplayOPC_COM_ErrorValue("Connect", Err.Number)
    ConnectOPCServer = False
SkipOPCConnectError:
End Function

Function DisconnectOPCServer()
    On Error GoTo ShowOPCDisconnectError
    OPCServerObj.Disconnect
    DisconnectOPCServer = True
    
    GoTo SkipDisconnectError
ShowOPCDisconnectError:
    Call DisplayOPC_COM_ErrorValue("Disconnect", Err.Number)
    DisconnectOPCServer = False
SkipDisconnectError:
End Function
'
Function GetOPCServerKey()
    GetOPCServerKey = OPCServerKey
End Function
'
Function GetOPCServerGroupCollection()
    Set GetOPCServerGroupCollection = OPCServerGroups
End Function
'
Function GetOPCServerIndex()
    GetOPCServerIndex = OPCServerIndex
End Function
'
Function GetServerName(ByRef ServerName As String)
    ServerName = OPCServerName
    GetServerName = True
End Function

Function GetStartTime(ByRef StartTime As Date)
    On Error GoTo ShowOPCStartTimeError
    StartTime = OPCServerObj.StartTime
    GetStartTime = True
    GoTo SkipOPCStartTimeError
    
ShowOPCStartTimeError:
    Call DisplayOPC_COM_ErrorValue("StartTime", Err.Number)
    GetStartTime = False
    
SkipOPCStartTimeError:
End Function

Function GetCurrentTime(ByRef CurrentTime As Date)
    On Error GoTo ShowOPCCurrentTimeError
    
    CurrentTime = OPCServerObj.CurrentTime
    GetCurrentTime = True
    GoTo SkipOPCCurrentTimeError
    
ShowOPCCurrentTimeError:
    Call DisplayOPC_COM_ErrorValue("CurrentTime", Err.Number)
    GetCurrentTime = False
    
SkipOPCCurrentTimeError:
End Function

Function GetLastUpdateTime(ByRef LastUpdateTime As Date)
    On Error GoTo ShowOPCLastUpdateTimeError
    LastUpdateTime = OPCServerObj.LastUpdateTime
    GetLastUpdateTime = True
    GoTo SkipOPCLastUpdateTimeError
    
ShowOPCLastUpdateTimeError:
    Call DisplayOPC_COM_ErrorValue("LastUpdate", Err.Number)
    GetLastUpdateTime = False
    
SkipOPCLastUpdateTimeError:
End Function

Function GetMajorVersion(ByRef MajorVersion As Integer)
    On Error GoTo ShowOPCMajorVersionError
    MajorVersion = OPCServerObj.MajorVersion
    GetMajorVersion = True
    GoTo SkipOPCMajorVersionError
    
ShowOPCMajorVersionError:
    Call DisplayOPC_COM_ErrorValue("MajorVersion", Err.Number)
    GetMajorVersion = False
    
SkipOPCMajorVersionError:
End Function

Function GetMinorVersion(ByRef MinorVersion As Integer)
    On Error GoTo ShowOPCMinorVersionError
    MinorVersion = OPCServerObj.MinorVersion
    GetMinorVersion = True
    GoTo SkipOPCMinorVersionError
    
ShowOPCMinorVersionError:
    Call DisplayOPC_COM_ErrorValue("MinorVersion", Err.Number)
    GetMinorVersion = False
    
SkipOPCMinorVersionError:
End Function
'
Function GetBuildNumber(ByRef BuildNumber As Integer)
    On Error GoTo ShowOPCBuildNumberError
    BuildNumber = OPCServerObj.BuildNumber
    GetBuildNumber = True
    GoTo SkipOPCBuildNumberError
    
ShowOPCBuildNumberError:
    Call DisplayOPC_COM_ErrorValue("BuildNumber", Err.Number)
    GetBuildNumber = False
    
SkipOPCBuildNumberError:
End Function

Function GetVendorInfo(ByRef VendorInfo As String)
    On Error GoTo ShowOPCVendorInfoError
    VendorInfo = OPCServerObj.VendorInfo
    GetVendorInfo = True
    GoTo SkipOPCVendorInfoError
    
ShowOPCVendorInfoError:
    Call DisplayOPC_COM_ErrorValue("VendorInfo", Err.Number)
    GetVendorInfo = False
    
SkipOPCVendorInfoError:
End Function


' Get the Server State property of the connected server
' The value retured will be one of the following
' OPC_STATUS_RUNNING      - 1 - Server is running normally
' OPC_STATUS_FAILED       - 2 - Vendor specific fatal error has occured
' OPC_STATUS_NOCONFIG     - 3 - Server Running but no Configuration Data available
' OPC_STATUS_SUSPENDED    - 4 - Server is suspended and not receiving data
' OPC_STATUS_TEST         - 5 - Server in test mode
' OPC_STATUS_DISCONNECTED - 6 - Server has disconnected
'
Function GetServerState(ByRef ServerState As Long)
    On Error GoTo ShowOPCServerStateError
    ServerState = OPCServerObj.ServerState
    GetServerState = True
    GoTo SkipOPCServerStateError
    
ShowOPCServerStateError:
    Call DisplayOPC_COM_ErrorValue("ServerState", Err.Number)
    GetServerState = False
    
SkipOPCServerStateError:
End Function

Function GetServerBrowseObject(ByRef OPCBrowserObject As OPCBrowserClass)
    On Error GoTo ShowOPCBrowserError
    
    Dim OPCBrowserObj As OPCBrowser
    Set OPCBrowserObj = OPCServerObj.CreateBrowser
    If Not OPCBrowserObj Is Nothing Then
        Set OPCBrowserObject = New OPCBrowserClass
        OPCBrowserObject.SetBrowserObject OPCBrowserObj
    Else
        Set OPCBrowserObject = Nothing
    End If
    GetServerBrowseObject = True
    GoTo SkipOPCBrowserError
    
ShowOPCBrowserError:
    Call DisplayOPC_COM_ErrorValue("Browser Object", Err.Number)
    GetServerBrowseObject = False
    
SkipOPCBrowserError:
End Function
'
Function SetDefaultGroupIsActive(ByVal State As Boolean)
    On Error GoTo ShowOPCDefaultGroupIsActiveError
    
    ServerGroups.DefaultGroupIsActive = State
    SetDefaultGroupIsActive = True
    GoTo SkipOPCDefaultGroupIsActiveError
    
ShowOPCDefaultGroupIsActiveError:
    Call DisplayOPC_COM_ErrorValue("DefaultGroupIsActive", Err.Number)
    SetDefaultGroupIsActive = False
    
SkipOPCDefaultGroupIsActiveError:
End Function
'
Function SetDefaultGroupUpdateRate(ByVal Rate As Long)
    'Set error handling for OPC Function
    On Error GoTo ShowOPCDefaultUpdateRateError
    
    ServerGroups.DefaultGroupUpdateRate = Rate
    SetDefaultGroupUpdateRate = True
    GoTo SkipOPCDefaultUpdateRateError
    
ShowOPCDefaultUpdateRateError:
    Call DisplayOPC_COM_ErrorValue("SetDefaultGroupUpdateRate", Err.Number)
    SetDefaultGroupUpdateRate = False
    
SkipOPCDefaultUpdateRateError:
End Function

Function SetDefaultGroupDeadBand(ByVal DeadBand As Single)
    On Error GoTo ShowOPCDefaultGroupDeadBandError
    
    ServerGroups.DefaultGroupDeadband = DeadBand
    SetDefaultGroupDeadBand = True
    GoTo SkipOPCDefaultGroupDeadBandError
    
ShowOPCDefaultGroupDeadBandError:
    Call DisplayOPC_COM_ErrorValue("SetDefaultGroupDeadBand", Err.Number)
    SetDefaultGroupDeadBand = False
    
SkipOPCDefaultGroupDeadBandError:
End Function

Function GetDefaultGroupIsActive(ByRef State As Boolean)
    On Error GoTo ShowOPCGetDefaultGroupIsActiveError
    
    State = ServerGroups.DefaultGroupIsActive
    GetDefaultGroupIsActive = True
    GoTo SkipOPCGetDefaultGroupIsActiveError
    
ShowOPCGetDefaultGroupIsActiveError:
    Call DisplayOPC_COM_ErrorValue("GetDefaultGroupIsActive", Err.Number)
    GetDefaultGroupIsActive = False
    
SkipOPCGetDefaultGroupIsActiveError:
End Function
'
Function GetDefaultGroupUpdateRate(ByRef Rate As Long)
    On Error GoTo ShowOPCGetDefaultUpdateRateError
    
    Rate = ServerGroups.DefaultGroupUpdateRate
    GetDefaultGroupUpdateRate = True
    GoTo SkipOPCGetDefaultUpdateRateError
    
ShowOPCGetDefaultUpdateRateError:
    Call DisplayOPC_COM_ErrorValue("GetDefaultGroupUpdateRate", Err.Number)
    GetDefaultGroupUpdateRate = False
    
SkipOPCGetDefaultUpdateRateError:
End Function

'
Function GetDefaultGroupDeadBand(ByRef DeadBand As Single)
    On Error GoTo ShowOPCGetDefaultGroupDeadBandError
    
    DeadBand = ServerGroups.DefaultGroupDeadband
    GetDefaultGroupDeadBand = True
    GoTo SkipOPCGetDefaultGroupDeadBandError
    
ShowOPCGetDefaultGroupDeadBandError:
    Call DisplayOPC_COM_ErrorValue("GetDefaultGroupDeadBand", Err.Number)
    GetDefaultGroupDeadBand = False
    
SkipOPCGetDefaultGroupDeadBandError:
End Function

Function AddOPCGroup(GroupName As String, UpdateRate As Long, DeadBand As Single, ActiveState As Boolean, ByRef GroupKey As String)
    On Error GoTo ShowOPCGroupAddError
    
    Dim ConnectedGroup As New OPCGroupClass
    Dim NewGroup As OPCGroup
    Dim GroupNum As Integer
    
    SetDefaultGroupIsActive (ActiveState)
    SetDefaultGroupUpdateRate (UpdateRate)
    SetDefaultGroupDeadBand (DeadBand)
    Set NewGroup = ServerGroups.Add(GroupName)

    If GroupName = "" Then
        GroupName = NewGroup.Name
    End If
    GroupNum = FindNextGroupNumber
    GroupKey = "Group" + Str(GroupNum) + Str(OPCServerIndex)
    If GroupName = "" Then
        GroupName = GroupKey
    End If
    ConnectedGroup.SetOPCGroup NewGroup, GroupName, GroupKey, GroupNum
    With OPCServerGroups
        .Add ConnectedGroup, GroupKey
    End With
        
    AddOPCGroup = True
    GoTo SkipAddGroupError

ShowOPCGroupAddError:
    Call DisplayOPC_COM_ErrorValue("Add Group", Err.Number)
    AddOPCGroup = False
    
SkipAddGroupError:
End Function
Private Function FindNextGroupNumber()
    On Error GoTo FoundNextGroupNumber
    
    Dim i As Integer
    Dim GroupNum As Integer
    
    GroupNum = 1
    
    With OPCServerGroups
        For i = 1 To .Count
            GroupNum = i
            .Item ("Group" + Str(i) + Str(OPCServerIndex))
        Next i
        If .Count <> 0 Then
            FindNextGroupNumber = i
        Else
            FindNextGroupNumber = 1 ' No count return the first 1
        End If
    End With
    
    GoTo NewGroup
    
FoundNextGroupNumber:
    FindNextGroupNumber = GroupNum
    
NewGroup:
End Function

Function RemoveOPCGroup(GroupKey As String)
    On Error GoTo ShowOPCGroupRemoveError
      
    Dim OPCGroupCls As OPCGroupClass
    Set OPCGroupCls = OPCServerGroups.Item(GroupKey)
    Dim GroupName As String
    GroupName = OPCGroupCls.GetGroupName
    ServerGroups.Remove GroupName
    OPCServerGroups.Remove GroupKey
    RemoveOPCGroup = True
    GoTo SkipRemoveGroupError

ShowOPCGroupRemoveError:
    Call DisplayOPC_COM_ErrorValue("Remove Group", Err.Number)
    RemoveOPCGroup = False
    
SkipRemoveGroupError:
End Function
'
Private Sub OPCServerObj_ServerShutDown(ByVal Reason As String)
    ' If we receive a server shut down message we need to release everthing and remove the server
    ' connection.
    RaiseEvent ServerShuttingDown(OPCServerKey)
End Sub

Private Sub Class_Initialize()
    Set OPCServerObj = New OPCServer
End Sub

Private Sub Class_Terminate()
    If Not ServerGroups Is Nothing Then
        If ServerGroups.Count <> 0 Then
            ServerGroups.RemoveAll
        End If
    End If
    If OPCServerGroups.Count <> 0 Then
        Dim i As Integer
        Dim a As Integer
        a = OPCServerGroups.Count
        For i = 1 To OPCServerGroups.Count
            With OPCServerGroups
            .Remove (a)
            a = a - 1
            End With
        Next i
    End If
    Set OPCServerGroups = Nothing
    
End Sub

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