建立如下窗体:
引用如下:
代码如下:
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:&nb [1] [2] 下一页 [VB.NET程序]OPC客户程序(VB篇——同步)
|