mainform.frm

西门子 通信程序 vb与西门子PLc通讯程序源码

'       |  OPCGoup           |
'       |     -------------- |
'       |     | OPCItems   | |
'       |     | Collection | |
'       ----------|-----------
'                 |
'                 |  -----------
'                 |--| OPCItem |
'                 |  -----------
'                 |  -----------
'                 |--| OPCItem |
'                 |  -----------

Private MyOPCServer As OPCServer        ' OPCServer Object
Private MyGroups As OPCGroups           ' OPCGroups Collection Object
Private WithEvents MyGroup As OPCGroup  ' OPCGroup Object
Attribute MyGroup.VB_VarHelpID = -1
Private MyItems As OPCItems             ' OPCItems Collection Object
Private MyItemServerHandles() As Long   ' Server Handles for Items
Dim MyTID As Long                       ' Transaction ID for asynchronous calls


Private Sub cmdConnect_Click()
On Error GoTo ErrorHandler
    
    Set MyOPCServer = New OPCServer           ' Create OPCServer Object
    
    Call MyOPCServer.Connect(txtServer.Text)  ' Disconnect from OPC Server
    
    ' Set Button Enable
    cmdConnect.Enabled = False
    cmdDisconnect.Enabled = True
    cmdAddGroup.Enabled = True
Exit Sub
ErrorHandler:
    MsgBox Err.Description + Chr(13) + "Connecting to OPC Server", vbCritical, "ERROR"
End Sub

Private Sub cmdDisconnect_Click()
On Error GoTo ErrorHandler
    
    MyOPCServer.Disconnect          ' Disconnect from OPC Server
    
    Set MyOPCServer = Nothing       ' Delete OPCServer Object
    
    ' Set Button Enable
    cmdDisconnect.Enabled = False
    cmdAddGroup.Enabled = False
    cmdConnect.Enabled = True
Exit Sub
ErrorHandler:
    MsgBox Err.Description + 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
    
    ' Set Default Properties for Group Collection
    ' These Properties are used to set the Properies for new Groups
    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
    ' Set Group Properties
    MyGroup.IsSubscribed = True   ' Enable Callbacks
    If CheckGroupActive.Value = 1 Then
        MyGroup.IsActive = True
    Else
        MyGroup.IsActive = False
    End If
    
    ' Set Button Enable
    cmdAddGroup.Enabled = False
    cmdDisconnect.Enabled = False
    cmdRemGroup.Enabled = True
    cmdAddItem.Enabled = True
Exit Sub
ErrorHandler:
    MsgBox Err.Description + 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
    
    ' Set Button Enable
    cmdRemGroup.Enabled = False
    cmdAddItem.Enabled = False
    cmdAddGroup.Enabled = True
    cmdDisconnect.Enabled = True
Exit Sub
ErrorHandler:
    MsgBox Err.Description + 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(2) As String
    Dim ItemClientHandles(2) As Long
    Dim Errors() As Long             ' Array for returned Item related errors
    ErrorFlag = False
    
    Set MyItems = MyGroup.OPCItems          ' Get OPCItems Collection Object from MyOPCServer
   
    ' Initialize the [IN] parameters for the Add Items call
    ' ItemIDs -> ItemIDs of the Items to add
    ' ItemClientHandles -> Client defined handles for the Items. The Server sends these handles in the Callbacks
    ItemIDs(1) = txtItem1.Text   ' Read ItemId 1 from Text Box
    ItemIDs(2) = txtItem2.Text   ' Read ItemId 2 from Text Box
    ItemClientHandles(1) = 1
    ItemClientHandles(2) = 2
    ' [OUT] parameters are
    ' ItemServerHandles -> Server defined handles for the Items. The client must use these handles for all Read/Write calls
    ' Errors -> Item related errors
    
    ' Add Items to the Group
    Call MyItems.AddItems(2, ItemIDs, ItemClientHandles, MyItemServerHandles, Errors)
    
    ' Check Item Errors
    For i = 1 To 2
        If Not Errors(i) = 0 Then
            MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
            ErrorFlag = True
        End If
    Next
    
    ' Continue only if all Items SUCCEEDED
    If ErrorFlag Then
        Dim RemoveErrors() As Long
        Dim RemoveHandles(1) As Long
        ' Remove Succeede Items
        For i = 1 To 2
            If Errors(i) = 0 Then
                RemoveHandles(1) = MyItemServerHandles(i)
                Call MyItems.Remove(1, RemoveHandles, RemoveErrors)
            End If
        Next
    Else
        ' Set Button Enable
        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.Description + 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
    
    ' Remove Items from the Group
    Call MyItems.Remove(2, MyItemServerHandles, Errors)
     
    ' Check Item Errors
    For i = 1 To 2
        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
    
    ' Set Button Enable
    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.Description + 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(2) As Variant
    Dim Errors() As Long             ' Array for returned Item related errors

    ' Initialize the [IN] parameters for the SyncWrite call
    ' Values -> Values to write
    Values(1) = txtWriteVal1.Text   ' Read Value 1 from Text Box
    Values(2) = txtWriteVal2.Text   ' Read Value 2 from Text Box
    ' ItemServerHandles -> Server defined handles from the AddItems call
    
    ' Write Values Syncronous
    Call MyGroup.SyncWrite(2, MyItemServerHandles, Values, Errors)
     
    ' Check Item Errors
    For i = 1 To 2
        If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
    Next

Exit Sub
ErrorHandler:
    MsgBox Err.Description + 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

    ' [IN] parameters for the SyncRead call
    ' ItemServerHandles -> Server defined handles from the AddItems call
    
    ' Read Values Syncronous
    Call MyGroup.SyncRead(OPCDevice, 2, MyItemServerHandles, Values, Errors, Qualities, TimeStamps)
     
    ' Check [OUT] Parameters
    For i = 1 To 2
        If Not Errors(i) = 0 Then
            MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
        Else
            ' Values -> Values from read
            ' Qualities -> Qualities of the returned values
            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.Description + Chr(13) + "Reading Items Syncronous", vbCritical, "ERROR"
End Sub

Private Sub cmdWriteAsync_Click()
On Error GoTo ErrorHandler
    Dim i As Long
    Dim Values(2) As Variant
    Dim Errors() As Long            ' Array for returned Item related errors
    Dim CID As Long                 ' CancelID, servergenerierter Wert, mit dem die Transaktion identifiziert

    ' Initialize the [IN] parameters for the SyncWrite call
    ' Values -> Values to write
    Values(1) = txtWriteVal1.Text   ' Read Value 1 from Text Box
    Values(2) = txtWriteVal2.Text   ' Read Value 2 from Text Box
    ' ItemServerHandles -> Server defined handles from the AddItems call
    MyTID = MyTID + 1   ' Increment Transaction ID
    
    ' Write Values Asyncronous
    Call MyGroup.AsyncWrite(2, MyItemServerHandles, Values, Errors, MyTID, CID)
     
    ' Check Item Errors
    For i = 1 To 2
        If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
    Next

Exit Sub
ErrorHandler:
    MsgBox Err.Description + 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
    
    ' [IN] parameters for the AsyncRead call
    ' ItemServerHandles -> Server defined handles from the AddItems call
    MyTID = MyTID + 1   ' Increment Transaction ID
    
    ' Read Values Syncronous
    Call MyGroup.AsyncRead(2, MyItemServerHandles, Errors, MyTID, CID)
     
    ' Check Item Errors
    For i = 1 To 2
        If Not Errors(i) = 0 Then MsgBox "Item " + Str$(i) + " FAILED. Error Code = " + Str$(Errors(i)), vbCritical
    Next

Exit Sub
ErrorHandler:
    MsgBox Err.Description + Chr(13) + "Reading Items Asyncronous", vbCritical, "ERROR"
End Sub

' Callback from AsyncRead
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
    
    ' Check Parameters
    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
            ' Values -> Values from read complete
            ' Qualities -> Qualities of the values
            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.Description + Chr(13) + "Async Read Complete", vbCritical, "ERROR"
End Sub

' Callback from AsyncWrite
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
    
    ' Check Item Errors
    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.Description + Chr(13) + "Async Write Complete", vbCritical, "ERROR"
End Sub

' Callback from OnDataChange
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
    
    ' Check Parameters
    For i = 1 To NumItems
        If ClientHandles(i) > 0 And ClientHandles(i) < 3 Then
            ' Values -> Values from read complete
            ' Qualities -> Qualities of the values
            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.Description + Chr(13) + "OnDataChange", vbCritical, "ERROR"
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

' Load Form Event
Private Sub Form_Load()
    MyTID = 1           ' Reset Transaction ID
End Sub

' Unload Form Event
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