OPC客户程序（VB篇——异步）

建立如下窗体：

引用如下：

代码如下：

Option Explicit
Option Base 1
            

Const WRITEASYNC_ID = 1
Const READASYNC_ID = 2
Const REFRESHASYNC_ID = 3

'----------------------------------------------------------------------------
' Interface Objects
'----------------------------------------------------------------------------
Public WithEvents ServerObj As OPCServer
Public WithEvents GroupObj As OPCGroup

Dim ItemObj1 As OPCItem
Dim ItemObj2 As OPCItem

Dim Serverhandle(2) As Long

Private Sub chkGroupActive_Click()

    If chkGroupActive = 1 Then
        GroupObj.IsActive = 1
    Else
        GroupObj.IsActive = 0
    End If
End Sub

Private Sub Command_Start_Click()

    Dim OutText As String
   
    On Error GoTo ErrorHandler
   
    Command_Start.Enabled = False
    Command_Read.Enabled = True
    Command_Write.Enabled = True
    Command_Exit.Enabled = True
    chkGroupActive.Enabled = True
           
    OutText = "连接OPC服务器"
    Set ServerObj = New OPCServer
    ServerObj.Connect ("XXXSERVER")
   
    OutText = "添加组"
    Set GroupObj = ServerObj.OPCGroups.Add("Group")
   
  
    GroupObj.IsSubscribed = True
   
    chkGroupActive_Click
   
    OutText = "添加ITEM"
    Set ItemObj1 = GroupObj.OPCItems.AddItem("XXXITEM1", 1)
    Set ItemObj2 = GroupObj.OPCItems.AddItem("XXXITEM2", 2)
   
    Serverhandle(1) = ItemObj1.Serverhandle
    Serverhandle(2) = ItemObj2.Serverhandle
   
    Exit Sub

ErrorHandler:
    MsgBox Err.Description + Chr(13) + _
         OutText, vbCritical, "ERROR"
   

End Sub

Private Sub Command_Read_Click() '异步读

    Dim OutText As String
    Dim myValue As Variant
    Dim myQuality As Variant
    Dim myTimeStamp As Variant
    Dim ClientID As Long
    Dim ServerID As Long
    Dim ErrorNr() As Long
    Dim ErrorString As String
           
    On Error GoTo ErrorHandler
    OutText = "读值"
   
    ClientID = READASYNC_ID
    GroupObj.AsyncRead 1, Serverhandle, ErrorNr, ClientID, ServerID
    If ErrorNr(1) <> 0 Then
        ErrorString = ServerObj.GetErrorString(ErrorNr(1))
        MsgBox ErrorString, vbCritical, "Error AsyncRead()"
    End If
          
    Erase ErrorNr
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Description + Chr(13) + _
         OutText, vbCritical, "ERROR"
   
End Sub

Private Sub Command_Write_Click() '异步写
   
    Dim OutText As String
    Dim Serverhandles(1) As Long
    Dim MyValues(1) As Variant
    Dim ErrorNr() As Long
    Dim ErrorString As String
    Dim Cancel_id As Long
       
    OutText = "Writing Value"
    On Error GoTo ErrorHandler
   
  
    MyValues(1) = Edit_WriteVal
   
    GroupObj.AsyncWrite 1, Serverhandle, MyValues, ErrorNr, WRITEASYNC_ID, Cancel_id
   
    If ErrorNr(1) <> 0 Then
        ErrorString = ServerObj.GetErrorString(ErrorNr(1))
        MsgBox ErrorString, vbCritical, "Error AsyncRead()"
    End If
 
    Erase ErrorNr
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Description + Chr(13) + _
         OutText, vbCritical, "ERROR"

End Sub

Private Sub Command_Exit_Click() '停止
    Dim OutText As String
   
    On Error GoTo ErrorHandler

    Command_Start.Enabled = True
    Command_Read.Enabled = False
    Command_Write.Enabled = False
    Command_Exit.Enabled = False
    chkGroupActive.Enabled = False
           
    OutText = "Removing Objects"
    Set ItemObj1 = Nothing
    Set ItemObj2 = Nothing
    ServerObj.OPCGroups.RemoveAll
    Set GroupObj = Nothing
    ServerObj.Disconnect
    Set ServerObj = Nothing
   
    Exit Sub
   
ErrorHandler:
    MsgBox Err.Description + Chr(13) + _
         OutText, vbCritical, "ERROR"
  
End Sub

'异步读回调
Private Sub GroupObj_AsyncReadComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date, Errors() As Long)
    Dim ErrorString As String
   
    If (TransactionID = READASYNC_ID) Then
        If Errors(1) = 0 Then
            Edit_ReadVal = ItemValues(1)
            Edit_ReadQu = GetQualityText(Qualities(1))
            Edit_ReadTS = TimeStamps(1)
        Else
            ErrorString = ServerObj.GetErrorString(Errors(1))
            MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
        End If
    End If
End Sub

'异步写回调
Private Sub GroupObj_AsyncWriteComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, Errors() As Long)
    Dim ErrorString As String
   
    If (TransactionID = WRITEASYNC_ID) Then
        If Errors(1) = 0 Then
            Edit_WriteRes = ServerObj.GetErrorString(Errors(1))
        Else
            ErrorString = ServerObj.GetErrorString(Errors(1))
            MsgBox ErrorString, vbCritical, "Error AsyncWriteComplete()"
        End If
    End If
End Sub
'回调
Private Sub GroupObj_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)

Dim i As Long

For i = 1 To NumItems
    Edit_OnDataVal(i - 1) = ItemValues(i)
    Edit_OnDataQu(i - 1) = GetQualityText(Qualities(i))
    Edit_OnDataTS(i - 1) = TimeStamps(i)

Next i

End Sub

Private Function GetQualityText(Quality) As String

    Select Case Quality
        Case 0:     GetQualityText = "BAD"
        Case 64:    GetQualityText = "UNCERTAIN"
        Case 192:   GetQualityText = "GOOD"
        Case 8:     GetQualityText = "NOT_CONNECTED"
        Case 13:    GetQualityText = "DEVICE_FAILURE"
        Case 16:    GetQualityText = "SENSOR_FAILURE"
        Case 20:    GetQualityText = "LAST_KNOWN"
        Case 24:    GetQualityText = "COMM_FAILURE"
        Case 28:    GetQualityText = "OUT_OF_SERVICE"
        Case 132:   GetQualityText = "LAST_USABLE"
        Case 144:   GetQualityText = "SENSOR_CAL"
        Case 148:   GetQualityText = "EGU_EXCEEDED"
        Case 152:   GetQualityText = "SUB_NORMAL"
        Case 216:   GetQualityText = "LOCAL_OVERRIDE"
       
        Case Else: GetQualityText = "UNKNOWN ERROR"
    End Select

End Function

 

本文地址：http://com.8s8s.com/it/it42098.htm