建立如下窗体：
引用如下：
代码如下：
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