📄 asyncsample.frm
字号:
VERSION 5.00
Begin VB.Form Edit_ReadVal
Caption = "OPC Async Sample"
ClientHeight = 5430
ClientLeft = 60
ClientTop = 345
ClientWidth = 6510
LinkTopic = "Form1"
ScaleHeight = 5430
ScaleWidth = 6510
StartUpPosition = 3 'Windows Default
Begin VB.TextBox Edit_OnDataTS
Enabled = 0 'False
Height = 375
Index = 1
Left = 4560
TabIndex = 22
Top = 3840
Width = 1575
End
Begin VB.TextBox Edit_OnDataQu
Enabled = 0 'False
Height = 375
Index = 1
Left = 3120
TabIndex = 21
Top = 3840
Width = 1335
End
Begin VB.TextBox Edit_OnDataVal
Enabled = 0 'False
Height = 375
Index = 1
Left = 1920
TabIndex = 20
Top = 3840
Width = 1095
End
Begin VB.TextBox Edit_ReadTS
Enabled = 0 'False
Height = 375
Left = 4560
TabIndex = 16
Top = 1200
Width = 1575
End
Begin VB.TextBox Edit_ReadQu
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 15
Top = 1200
Width = 1335
End
Begin VB.TextBox Edit_ReadVal
Enabled = 0 'False
Height = 375
Left = 1920
TabIndex = 14
Top = 1200
Width = 1095
End
Begin VB.CheckBox chkGroupActive
Caption = "Group Active"
Enabled = 0 'False
Height = 255
Left = 360
TabIndex = 9
Top = 3000
Width = 1335
End
Begin VB.TextBox Edit_WriteVal
Height = 375
Left = 1920
TabIndex = 5
Top = 1800
Width = 1095
End
Begin VB.CommandButton Command_Start
Caption = "启动例子"
Height = 375
Left = 240
TabIndex = 4
Top = 240
Width = 1335
End
Begin VB.CommandButton Command_Read
Caption = "读"
Enabled = 0 'False
Height = 375
Left = 240
TabIndex = 3
Top = 1200
Width = 1335
End
Begin VB.CommandButton Command_Write
Caption = "写"
Enabled = 0 'False
Height = 375
Left = 240
TabIndex = 2
Top = 1800
Width = 1335
End
Begin VB.CommandButton Command_Exit
Caption = "停止"
Enabled = 0 'False
Height = 375
Left = 240
TabIndex = 1
Top = 4800
Width = 1335
End
Begin VB.TextBox Edit_WriteRes
Enabled = 0 'False
Height = 375
Left = 3120
MultiLine = -1 'True
TabIndex = 0
Top = 1800
Width = 3015
End
Begin VB.Frame Frame1
Caption = "On Data Changed"
Height = 1815
Left = 240
TabIndex = 10
Top = 2640
Width = 6015
Begin VB.TextBox Edit_OnDataTS
Enabled = 0 'False
Height = 375
Index = 0
Left = 4320
TabIndex = 19
Top = 720
Width = 1575
End
Begin VB.TextBox Edit_OnDataQu
Enabled = 0 'False
Height = 375
Index = 0
Left = 2880
TabIndex = 18
Top = 720
Width = 1335
End
Begin VB.TextBox Edit_OnDataVal
Enabled = 0 'False
Height = 375
Index = 0
Left = 1680
TabIndex = 17
Top = 720
Width = 1095
End
Begin VB.Label Label8
Caption = "时间戳"
Height = 255
Left = 4560
TabIndex = 13
Top = 360
Width = 855
End
Begin VB.Label Label7
Caption = "品质"
Height = 255
Left = 3240
TabIndex = 12
Top = 360
Width = 615
End
Begin VB.Label Label6
Caption = "值"
Height = 255
Left = 1920
TabIndex = 11
Top = 360
Width = 735
End
End
Begin VB.Label Label2
Caption = "值"
Height = 255
Left = 2160
TabIndex = 8
Top = 840
Width = 615
End
Begin VB.Label Label3
Caption = "品质/写结果"
Height = 375
Left = 3240
TabIndex = 7
Top = 720
Width = 1095
End
Begin VB.Label Label4
Caption = "时间戳"
Height = 255
Index = 0
Left = 4800
TabIndex = 6
Top = 840
Width = 855
End
End
Attribute VB_Name = "Edit_ReadVal"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'----------------------------------------------------------------------------
' OPC 自动化 2.0 例子
' 异步
'
'----------------------------------------------------------------------------
Option Explicit
Option Base 1
Const WRITEASYNC_ID = 1
Const READASYNC_ID = 2
Const REFRESHASYNC_ID = 3
'----------------------------------------------------------------------------
' 接口对象
'----------------------------------------------------------------------------
Public WithEvents ServerObj As OPCServer
Attribute ServerObj.VB_VarHelpID = -1
Public WithEvents GroupObj As OPCGroup
Attribute GroupObj.VB_VarHelpID = -1
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 ("Matrikon.OPC.Simulation")
OutText = "添加组"
Set GroupObj = ServerObj.OPCGroups.Add("MyOPCGroup")
GroupObj.IsSubscribed = True
chkGroupActive_Click
OutText = "为组添加Item"
Set ItemObj1 = GroupObj.OPCItems.AddItem("Random.Real4", 1)
Set ItemObj2 = GroupObj.OPCItems.AddItem("Random.Real8", 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 = "写值"
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 = "删除对象"
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -