form1.frm

OPC通讯测试

Private Sub cmdAdvise_Click()
    Call AdviseUnadvise
End Sub

Private Sub cmdAsyncRead_Click()
    Call AsyncRead
End Sub

Private Sub cmdAsyncWrite_Click()
    Call AsyncWrite
End Sub

Private Sub cmdConnect_Click()

    If cmdConnect.Caption = "&Connect" Then
        Call ConnectServer
    Else
        Call DisconnectServer
    End If

End Sub

Private Sub Form_Load()
'获取opc服务器的名称，并添加到列表控件中

    Dim opcservers() As OPCAutomation.OPCServer
    Dim ServerNames() As String
    Set MyOPCServer = New OPCServer
    
    ServerNames = MyOPCServer.GetOPCServers()
    
    Dim ServerCount As Integer
    
    For Each element In ServerNames()
        ServerCount = ServerCount + 1
        CmbServer.AddItem element
    Next
    
    If ServerCount = 0 Then TxtState = "No opcserver"
End Sub

Private Sub Form_Unload(Cancel As Integer)

    'always make sure references are closed when shutting application down
    
    On Error Resume Next
    
    'Remove OPC group definition in server
    MyOPCServer.OPCGroups.RemoveAll
    'Drop object reference
    Set MyOPCGroup = Nothing
    'Disconnect from server
    MyOPCServer.Disconnect
    'Drop object reference
    Set MyOPCServer = Nothing
End Sub

Public Sub ConnectServer()

    Dim i As Long
    Dim sRemoteMachine As String
    
    On Error GoTo ErrorHandler
    
    Screen.MousePointer = vbHourglass
    
    If Len(txtMachine) > 0 Then
        txtStatus = "Connecting to OPC Server on " & txtMachine
        Me.Refresh
        sRemoteMachine = txtMachine
        'attempt to connect to remote server
        MyOPCServer.Connect CmbServer.Text, sRemoteMachine
    Else
        txtStatus = "Connecting to local OPC Server ..."
        Me.Refresh
        'attempt to connect to local server
        MyOPCServer.Connect CmbServer.Text
    End If
    
    ' Need to Create an OPC Group
    Set MyOPCGroup = MyOPCServer.OPCGroups.Add("OPCDemo")
    'set default state subscription to capture data changes
    MyOPCGroup.IsSubscribed = True
    'Set group inactive
    MyOPCGroup.IsActive = False
    If Len(txtUpdate) > 0 And IsNumeric(txtUpdate) Then
        MyOPCGroup.UpdateRate = txtUpdate.Text
    Else
        'use default
        MyOPCGroup.UpdateRate = 1000
    End If
    
    cmdConnect.Caption = "&Disconnect"
    txtStatus = "Connected to server"
    ' Enable Add Items button
    cmdAddItems.Enabled = True
    TxtTopic(0).SetFocus
    Screen.MousePointer = vbDefault
Exit Sub

ErrorHandler:
    Screen.MousePointer = vbDefault
    txtStatus = ""
    PostMessage Err.Number
End Sub



Public Sub PostMessage(lError As Long)

    Dim sText As String
    
    Screen.MousePointer = vbDefault
    
    sText = MyOPCServer.GetErrorString(lError)
    If InStr(sText, vbCrLf) Then
        'strip off crlf at end of string
        sText = Left$(sText, Len(sText) - 2)
    End If
    txtStatus = sText
    MsgBox "Runtime error '" & lError & "' (0x" & Hex(lError) & ")" & _
                vbCrLf & vbCrLf & sText, vbInformation
End Sub



Public Sub DisconnectServer()
    
    Dim i As Long

    On Error Resume Next
    
    'Remove OPC group definition in server
    MyOPCServer.OPCGroups.RemoveAll
    'Drop object reference
    Set MyOPCGroup = Nothing
    'Disconnect from server
    MyOPCServer.Disconnect
    
    'Disable all buttons
    cmdAddItems.Enabled = False
    cmdAsyncRead.Enabled = False
    cmdAsyncWrite.Enabled = False
    cmdAdvise.Enabled = False
    
    cmdConnect.Caption = "&Connect"
    txtStatus = "Disconnected from server"
End Sub


Public Function AddOPCItems() As Boolean

    Dim arItemIDs() As String
    Dim arClientHandles() As Long
    Dim arServerHandles() As Long
    Dim arErrors() As Long
    Dim i As Long
    Dim lIndex As Long
    Dim oOPCItem As OPCAutomation.OPCItem
    
    On Error GoTo ErrorHandler
    
    ' Remove existing OPC items if they exist
    If MyOPCGroup.OPCItems.Count Then
        MyOPCGroup.IsActive = False
        Call RemoveOPCItems
    End If
    
    ' Redim arrays to maximum possible size
    ReDim arItemIDs(1 To 4)
    ReDim arClientHandles(1 To 4)
    
    For i = 0 To 3
        If Len(TxtTopic(i)) > 0 And Len(TxtItem(i)) > 0 Then
            lIndex = lIndex + 1
            ' Build array of itemIDs by combining Topic and Item specification
            ' in the form of [<topic>]<item>
            arItemIDs(lIndex) = "[" & TxtTopic(i) & "]" & TxtItem(i)
            arClientHandles(lIndex) = i
        End If
    Next    'i
    
    If lIndex Then
        ' Redim arrays to actual number of items being added
        ReDim Preserve arItemIDs(1 To lIndex)
        ReDim Preserve arClientHandles(1 To lIndex)
        MyOPCGroup.OPCItems.AddItems lIndex, arItemIDs, arClientHandles, arServerHandles, arErrors
        ' Check for errors
        For i = LBound(arErrors) To UBound(arErrors)
            If arErrors(i) <> 0 Then
                txtStatus = GetErrorString(arErrors(i))
            End If
        Next    'i
        If MyOPCGroup.OPCItems.Count Then
'            On Error Resume Next
            If IsNumeric(txtUpdate) Then
                If txtUpdate.Text <> MyOPCGroup.UpdateRate Then
                    ' Change group update rate
                    MyOPCGroup.UpdateRate = txtUpdate.Text
                End If
            Else
                txtUpdate.Text = MyOPCGroup.UpdateRate
            End If
            ' return success
            AddOPCItems = True
        End If
    Else
        txtStatus = "No valid item definitions to add."
    End If
Exit Function

ErrorHandler:
    txtStatus = ""
    PostMessage Err.Number
End Function

Public Sub RemoveOPCItems()

    Dim arServerHandles() As Long
    Dim arErrors() As Long
    Dim i As Long
    Dim lNumitems As Long
    
    On Error GoTo ErrorHandler
    
    ' Remove existing OPC items if they exist
    lNumitems = MyOPCGroup.OPCItems.Count
    ' Dimension array for handles
    ReDim arServerHandles(1 To lNumitems)
    For i = 1 To lNumitems
        arServerHandles(i) = MyOPCGroup.OPCItems(i).ServerHandle
    Next    'i
    MyOPCGroup.OPCItems.Remove lNumitems, arServerHandles, arErrors

Exit Sub

ErrorHandler:
    txtStatus = ""
    PostMessage Err.Number
End Sub

Public Function GetErrorString(lErrCode As Long) As String

    Dim sText As String
    
    On Error Resume Next
    
    sText = MyOPCServer.GetErrorString(lErrCode)
    If InStr(sText, vbCrLf) Then
        'strip off crlf at end of string
        sText = Left$(sText, Len(sText) - 2)
    End If
    GetErrorString = sText
End Function




Public Sub AsyncRead()

' This function demonstrates how to perform an OPC Group Asynchronous Read operation.
' The data is returned in the callback function MyOPCGroup_AsyncReadComplete

    Dim lNumitems As Long
    Dim arHandles() As Long
    Dim arErrors() As Long
    Dim lTransID As Long
    Dim lCancelID As Long
    Dim sText As String
    Dim oOPCItem As RSLinxOPCAutomation.OPCItem
    
    On Error GoTo ErrorHandler
    
    txtStatus = "OPC Group Async Read in progress ..."
    'specify number of elements
    lNumitems = MyOPCGroup.OPCItems.Count
    ' Dimension server handles array
    ReDim arHandles(1 To lNumitems)
    For i = 1 To lNumitems
        'pass in server handles
        arHandles(i) = MyOPCGroup.OPCItems(i).ServerHandle
    Next    'i
    ' perform async read
    MyOPCGroup.AsyncRead lNumitems, arHandles, arErrors, lTransID, lCancelID
    ' check for error in passing parameters to server
    For i = 1 To lNumitems
        If arErrors(i) > 0 Then
            txtStatus = GetErrorString(arErrors(i))
        End If
    Next    'i
Exit Sub

ErrorHandler:
    PostMessage Err.Number
End Sub

Public Sub AsyncWrite()

' This function demonstrates how to perform an OPC Group Asynchronous Write operation.
' Any errors are reported in the callback function MyOPCGroup_AsyncWriteComplete
    
    Dim lNumitems As Long
    Dim arData() As Variant
    Dim arHandles() As Long
    Dim arErrors() As Long
    Dim lTransID As Long
    Dim lCancelID As Long
    Dim sText As String
    Dim i As Long
    
    On Error GoTo ErrorHandler
    
    txtStatus = "OPC Group Async Write operation in progress ..."
    'specify number of elements
    lNumitems = MyOPCGroup.OPCItems.Count
    ' Dimension arrays for item server handles and actual data being passed to server
    ReDim arHandles(1 To lNumitems)
    ReDim arData(1 To lNumitems)
    For i = 1 To lNumitems
        With MyOPCGroup
            'pass in the server handles
            arHandles(i) = .OPCItems(i).ServerHandle
            'pass in the data
            arData(i) = txtData(.OPCItems(i).ClientHandle).Text
        End With
    Next    'i
    'write data to server
    MyOPCGroup.AsyncWrite lNumitems, arHandles, arData, arErrors, lTransID, lCancelID
    For i = 1 To lNumitems
        If arErrors(i) > 0 Then
            txtStatus = GetErrorString(arErrors(i))
        End If
    Next    'i
Exit Sub

ErrorHandler:
    PostMessage Err.Number
End Sub

Public Sub AdviseUnadvise()

    Dim i As Long
    
    If cmdAdvise.Caption = "Advise" Then
        'turn on advise
        MyOPCGroup.IsActive = True
        cmdAdvise.Caption = "Deadvise"
        ' Update Status Text
        txtStatus = "Advise Started"
    Else
        'turn off advise
        MyOPCGroup.IsActive = False
        cmdAdvise.Caption = "Advise"
        ' Update Status Text
        txtStatus = "Advise Stopped"
    End If
End Sub



Private Sub MyOPCGroup_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 sText As String
    Dim i As Long
    
    On Error Resume Next
    
    For i = 1 To NumItems
        If VarType(ItemValues(i)) And vbArray Then
            '/* Convert arrayed items into a string before displaying
            txtData(ClientHandles(i)) = ConvertArrayToString(ItemValues(i))
        Else
            '/* Update display
            txtData(ClientHandles(i)) = ItemValues(i)
        End If
        ' Update Item Quality
        TxtQuality(ClientHandles(i)) = GetQualityString(Qualities(i))
        'Display error information
        txtStatus = GetErrorString(Errors(i))
    Next    'i
End Sub

Private Sub MyOPCGroup_AsyncWriteComplete(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, Errors() As Long)

    Dim i As Long
    
    On Error Resume Next
    
    For i = 1 To NumItems
        If Errors(i) > 0 Then
            'Display error information
            txtStatus = GetErrorString(Errors(i))
        End If
    Next    'i
End Sub

Public Function ConvertArrayToString(vArrayData As Variant) As String

    Dim i As Long
    Dim sTemp As String
    
    '/* Convert array data values into a concatenated string
    For i = LBound(vArrayData) To UBound(vArrayData) - 1
        sTemp = sTemp & vArrayData(i) & ","
    Next
    '/* Add last element
    sTemp = sTemp & vArrayData(i)
    '/* Return concatenated string
    ConvertArrayToString = sTemp
End Function