建立如下窗体：
引用如下：
代码如下：
Option Explicit
Dim WithEvents ServerObj As OPCServer
Dim WithEvents GroupObj As OPCGroup
Dim ItemObj As OPCItem
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
OutText = "连接OPC服务器"
Set ServerObj = New OPCServer
ServerObj.Connect ("XXXSERVER")'XXXSERVER为某OPC服务器名称
OutText = "添加组"
Set GroupObj = ServerObj.OPCGroups.Add("Group")
OutText = "Adding an Item to the group"
Set ItemObj = GroupObj.OPCItems.AddItem("XXXITEM", 1)'XXXITEM为添加的ITEM名称
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
On Error GoTo ErrorHandler
OutText = "读ITEM值"
ItemObj.Read OPCDevice, myValue, myQuality, myTimeStamp
Edit_ReadVal = myValue
Edit_ReadQu = GetQualityText(myQuality)
Edit_ReadTS = myTimeStamp
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 MyErrors() As Long
OutText = "写值"
On Error GoTo ErrorHandler
Serverhandles(1) = ItemObj.ServerHandle
MyValues(1) = Edit_WriteVal
GroupObj.SyncWrite 1, Serverhandles, MyValues, MyErrors
Edit_WriteRes = ServerObj.GetErrorString(MyErrors(1))
Exit Sub
ErrorHandler:
MsgBox Err.Description + Chr(13) + _
OutText, vbCritical, "ERROR"
End Sub
Private Sub Command_Exit_Click()'停止，删除ITEM,删除GROUP，删除SERVER。
Dim OutText As String
On Error GoTo ErrorHandler
Command_Start.Enabled = True
Command_Read.Enabled = False
Command_Write.Enabled = False
Command_Exit.Enabled = False
OutText = "删除对象"
Set ItemObj = 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 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
