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

http://www.opc-china.com
建立如下窗体：
 详见相册OPC技术。
引用如下：
详见相册OPC技术。
代码如下：
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