用VB实现OPC客户程序2

1、OPC客户程序（VB篇异步） 来源：   责任编辑：  作者：  41建立如下窗体： 引用如下： 代码如下： 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

2、 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.

3、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(&

4、quot;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.Serv

5、erhandle 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

6、 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, &qu

7、ot;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 Di

8、m 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) Ms

9、gBox 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

10、= 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 =

11、 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

12、() 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

13、, "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 Edi

14、t_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, ClientHandle

15、s() 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) A

16、s 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: GetQuali