Option Explicit
Option Base 1
Private MyOPCServer As OPCServer
Private MyGroups As OPCGroups
Private WithEvents MyGroup As OPCGroup
Private MyItems As OPCItems
Private MyItemServerHandles() As Long
Dim MyTID As Long
Private Sub cmdConnect_Click()
On Error GoTo ErrorHandler
Set MyOPCServer = New OPCServer
Call MyOPCServer.Connect(txtServer.Text)
cmdConnect.Enabled = False
cmdDisconnect.Enabled = True
cmdAddGroup.Enabled = True
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Connecting to OPC Server", vbCritical, "ERROR"
End Sub
Private Sub cmdDisconnect_Click()
On Error GoTo ErrorHandler
MyOPCServer.Disconnect
Set MyOPCServer = Nothing
cmdDisconnect.Enabled = False
cmdAddGroup.Enabled = False
cmdConnect.Enabled = True
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Disconnecting from OPC Server", vbCritical, "ERROR"
End Sub
Private Sub cmdAddGroup_Click()
On Error GoTo ErrorHandler
Set MyGroups = MyOPCServer.OPCGroups ' Get OPCGroups Collection Object from MyOPCServer
MyGroups.DefaultGroupIsActive = 500 ' Set Default Group Update Rate to 500 ms
MyGroups.DefaultGroupIsActive = False ' Set Default Group Active State to Inactive
Set MyGroup = MyGroups.Add(txtGroup.Text) ' Add a new Group to the Group Collection
MyGroup.IsSubscribed = True ' Enable Callbacks
If CheckGroupActive.Value = 1 Then
MyGroup.IsActive = True
Else
MyGroup.IsActive = False
End If
cmdAddGroup.Enabled = False
cmdDisconnect.Enabled = False
cmdRemGroup.Enabled = True
cmdAddItem.Enabled = True
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Adding a Group to OPC Server", vbCritical, "ERROR"
End Sub
Private Sub cmdRemGroup_Click()
On Error GoTo ErrorHandler
MyGroups.RemoveAll ' Removes all Groups
Set MyGroup = Nothing ' Delete OPCGroup Object
Set MyGroups = Nothing ' Delete OPCGroups Collection Object
cmdRemGroup.Enabled = False
cmdAddItem.Enabled = False
cmdAddGroup.Enabled = True
cmdDisconnect.Enabled = True
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Removing Group from OPC Server", vbCritical, "ERROR"
End Sub
Private Sub CheckGroupActive_Click()
If Not MyGroup Is Nothing Then
If CheckGroupActive.Value = 1 Then
MyGroup.IsActive = True
Else
MyGroup.IsActive = False
End If
End If
End Sub

Private Sub cmdAddItem_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim ErrorFlag As Boolean
Dim ItemObj As OPCItem
Dim ItemIDs(3) As String
Dim ItemClientHandles(3) As Long
ReDim MyItemServerHandles(3)
Dim Errors() As Long ' Array for returned Item related errors
ErrorFlag = False
Set MyItems = MyGroup.OPCItems ' Get OPCItems Collection Object from MyOPCServer
ItemIDs(1) = txtItem1.Text ' Read ItemId 1 from Text Box
ItemIDs(2) = txtItem2.Text ' Read ItemId 2 from Text Box
ItemIDs(3) = txtItem3.Text ' Read ItemId 2 from Text Box
ItemClientHandles(1) = 1
ItemClientHandles(2) = 2
ItemClientHandles(3) = 3
Call MyItems.AddItems(3, ItemIDs, ItemClientHandles, MyItemServerHandles, Errors)
For i = 1 To 3
If Not Errors(i) = 0 Then
MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
ErrorFlag = True
End If
Next
If ErrorFlag Then
Dim RemoveErrors() As Long
Dim RemoveHandles(1) As Long
For i = 1 To 3
If Errors(i) = 0 Then
RemoveHandles(1) = MyItemServerHandles(i)
Call MyItems.Remove(1, RemoveHandles, RemoveErrors)
End If
Next
Else
cmdAddItem.Enabled = False
cmdRemGroup.Enabled = False
cmdRemItem.Enabled = True
cmdWriteSync.Enabled = True
cmdWriteAsync.Enabled = True
cmdReadSync.Enabled = True
cmdReadAsync.Enabled = True
End If
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Adding Items to the Group", vbCritical, "ERROR"
End Sub

Private Sub cmdRemItem_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim Errors() As Long ' Array for returned Item related errors
Call MyItems.Remove(3, MyItemServerHandles, Errors)
For i = 1 To 3
If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Next
Erase MyItemServerHandles ' Erase Item Server Handle Array
cmdRemItem.Enabled = False
cmdWriteSync.Enabled = False
cmdWriteAsync.Enabled = False
cmdReadSync.Enabled = False
cmdReadAsync.Enabled = False
cmdAddItem.Enabled = True
cmdRemGroup.Enabled = True
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Removing Items from the Group", vbCritical, "ERROR"
End Sub
Private Sub cmdWriteSync_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim Values(3) As Variant
Dim Errors() As Long ' Array for returned Item related errors
Values(1) = txtWriteVal1.Text ' Read Value 1 from Text Box
Values(2) = txtWriteVal2.Text ' Read Value 2 from Text Box
Values(3) = txtWriteVal3.Text ' Read Value 2 from Text Box
Call MyGroup.SyncWrite(3, MyItemServerHandles, Values, Errors)
For i = 1 To 3
If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Writing Items Syncronous", vbCritical, "ERROR"
End Sub
Private Sub cmdReadSync_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim Values() As Variant
Dim Errors() As Long ' Array for returned Item related errors
Dim Qualities As Variant ' Array for returned Qualities of the Values
Dim TimeStamps As Variant ' Array for returned Timestamps of the Values
Call MyGroup.SyncRead(OPCDevice, 3, MyItemServerHandles, Values, Errors, Qualities, TimeStamps)
For i = 1 To 3
If Not Errors(i) = 0 Then
MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Else
If Qualities(i) = 192 Then
txtReadVal.Item(i - 1).Text = Values(i) ' Write Value to Text Box
txtReadVal.Item(i - 1).BackColor = &HFFFFFF
Else
txtReadVal.Item(i - 1).Text = GetQualityText(Qualities(i))
txtReadVal.Item(i - 1).BackColor = &H8080FF
End If
End If
Next

Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Reading Items Syncronous", vbCritical, "ERROR"
End Sub

Private Sub cmdWriteAsync_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim Values(3) As Variant
Dim Errors() As Long ' Array for returned Item related errors
Dim CID As Long ' CancelID, servergenerierter Wert, mit dem die Transaktion identifiziert
Values(1) = txtWriteVal1.Text ' Read Value 1 from Text Box
Values(2) = txtWriteVal2.Text ' Read Value 2 from Text Box
Values(3) = txtWriteVal2.Text ' Read Value 2 from Text Box
MyTID = MyTID + 1 ' Increment Transaction ID
Call MyGroup.AsyncWrite(3, MyItemServerHandles, Values, Errors, MyTID, CID)
For i = 1 To 3
If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Writing Items Asyncronous", vbCritical, "ERROR"
End Sub
Private Sub cmdReadAsync_Click()
On Error GoTo ErrorHandler
Dim i As Long
Dim Errors() As Long ' Array for returned Item related errors
Dim CID As Long ' CancelID, servergenerierter Wert, mit dem die Transaktion identifiziert
MyTID = MyTID + 1 ' Increment Transaction ID
Call MyGroup.AsyncRead(3, MyItemServerHandles, Errors, MyTID, CID)
For i = 1 To 3
If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Reading Items Asyncronous", vbCritical, "ERROR"
End Sub
Private Sub MyGroup_AsyncReadComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date, Errors() As Long)
On Error GoTo ErrorHandler
Dim i As Long
TxtAReadComplete.Text = TxtAReadComplete.Text + 1
For i = 1 To NumItems
If Not Errors(i) = 0 Then
MsgBox "AsyncReadComplete Item Clienthandle = " + Str$(ClientHandles(i)) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
ElseIf ClientHandles(i) > 0 And ClientHandles(i) < 3 Then
If Qualities(i) = 192 Then
txtReadVal.Item(ClientHandles(i) - 1).Text = ItemValues(i) ' Write Value to Text Box
txtReadVal.Item(ClientHandles(i) - 1).BackColor = &HFFFFFF
Else
txtReadVal.Item(ClientHandles(i) - 1).Text = GetQualityText(Qualities(i))
txtReadVal.Item(ClientHandles(i) - 1).BackColor = &H8080FF
End If
Else
MsgBox "AsyncWriteComplete Item " + Str$(i) + " has invalid Client Handle ", vbCritical
End If
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Async Read Complete", vbCritical, "ERROR"
End Sub
Private Sub MyGroup_AsyncWriteComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, Errors() As Long)
On Error GoTo ErrorHandler
Dim i As Long
TxtAWriteComplete.Text = TxtAWriteComplete.Text + 1
For i = 1 To NumItems
If Not Errors(i) = 0 Then MsgBox "AsyncWriteComplete Item Clienthandle = " + Str$(ClientHandles(i)) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "Async Write Complete", vbCritical, "ERROR"
End Sub
Private Sub MyGroup_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)
On Error GoTo ErrorHandler
Dim i As Long
TxtDataChange.Text = TxtDataChange.Text + 1
For i = 1 To NumItems
If ClientHandles(i) > 0 And ClientHandles(i) < 3 Then
If Qualities(i) = 192 Then
txtChangeVal.Item(ClientHandles(i) - 1).Text = ItemValues(i) ' Write Value to Text Box
txtChangeVal.Item(ClientHandles(i) - 1).BackColor = &HFFFFFF
Else
txtChangeVal.Item(ClientHandles(i) - 1).Text = GetQualityText(Qualities(i))
txtChangeVal.Item(ClientHandles(i) - 1).BackColor = &H8080FF
End If
Else
MsgBox "DataChange Item " + Str$(i) + " has invalid Client Handle ", vbCritical
End If
Next
Exit Sub
ErrorHandler:
MsgBox Err.Des cription + Chr(13) + "OnDataChange", vbCritical, "ERROR"
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub Form_Load()
MyTID = 1 ' Reset Transaction ID
End Sub
Private Sub Form_Unload(Cancel As Integer)
If cmdRemItem.Enabled = True Then Call cmdRemItem_Click
If cmdRemGroup.Enabled = True Then Call cmdRemGroup_Click
If cmdDisconnect.Enabled = True Then Call cmdDisconnect_Click
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 QUALITY"
End Select
End Function