vbopcclient.txt

vb编写的opc客户端程序

Option Explicit

Option Base 1

'On Error Resume Next

Const ServerName = "OPCServer.WinCC"
Dim WithEvents MyOPCServer As OPCServer
Dim WithEvents MyOPCGroup As OPCGroup
Dim MyOPCGroupColl As OPCGroups
Dim MyOPCItemColl As OPCItems
Dim MyOPCItems As OPCItems
Dim MyOPCItem As OPCItem
Dim li_err As Integer
Dim ClientHandles(1) As Long
Dim ServerHandles1() As Long
Dim ServerHandles2() As Long
Dim ServerHandles3() As Long
Dim ServerHandles4() As Long
Dim ServerHandles5() As Long
Dim values(1) As Variant
Dim Errors() As Long
Dim ItemIDs(2) As String
Dim GroupName As String
Dim NodeName As String
Dim li_count As Integer
Dim li_item As Integer
Dim li_time As Integer
Dim li_starting As Integer

'---------------------------------------------------------------------

' Sub StartClient()

' 目的：连接至OPC_server，创建组和添加条目

'---------------------------------------------------------------------

Sub StartClient()
   On Error GoTo ErrorHandler
  '----------- 可以自由选择ClientHandle和GroupName
  'On Error Resume Next
  ClientHandles(1) = 1
  GroupName = "MyGroup"
  '----------- 从单元“A1”得到ItemID
  NodeName = "zdh"
  '----------- 得到一个OPC服务器的实例
  Set MyOPCServer = New OPCServer
  MyOPCServer.Connect ServerName, NodeName
  Set MyOPCGroupColl = MyOPCServer.OPCGroups
  '----------- 为添加组设置缺省的激活状态
  MyOPCGroupColl.DefaultGroupIsActive = True
  '----------- 添加组至收集
  Set MyOPCGroup = MyOPCGroupColl.Add(GroupName)
  Set MyOPCItemColl = MyOPCGroup.OPCItems
  '----------- 添加一个条目、返回ServerHandles
  ItemIDs(1) = "ST-101"
  MyOPCItemColl.AddItems 1, ItemIDs, ClientHandles, ServerHandles1, Errors
  ItemIDs(1) = "ST-201"  
  MyOPCItemColl.AddItems 1, ItemIDs, ClientHandles, ServerHandles4, Errors
  ItemIDs(1) = "TIT-004"
  MyOPCItemColl.AddItems 1, ItemIDs, ClientHandles, ServerHandles5, Errors
  li_err = 0
  li_starting = 1
  '----------- 用于接受不同的信息组
  'MyOPCGroup.IsSubscribed = True
Exit Sub
ErrorHandler:
  'MsgBox "Error: " & err.Description, vbCritical, "ERROR"
  li_err = 1
End Sub

 

'---------------------------------------------------------------------

' Sub StopClient()

' 目的：从服务器释放对象并且断开连接

'---------------------------------------------------------------------

Sub StopClient()

  '----------- 释放组和服务器对象

  MyOPCGroupColl.RemoveAll

  '----------- 与服务器断开连接并且清除

  MyOPCServer.Disconnect

  Set MyOPCItemColl = Nothing

  Set MyOPCGroup = Nothing

  Set MyOPCGroupColl = Nothing

  Set MyOPCServer = Nothing

End Sub

 

Private Sub Command1_Click()
   StartClient
   
   'MyOPCGroup.OPCItems.Item.Read
   'Set tt = MyOPCItemColl.GetOPCItem
   
   'tt.Read 1, value
   
   
End Sub

Private Sub Command2_Click()
    
   ' If Winsock2.State = sckOpen Then
   Winsock2.SendData "11@speed@1@2"
   
   ' Else
    '    Winsock2.Close
   ' End If
End Sub

Private Sub Command3_Click()
Winsock2.Close
End Sub

Private Sub Form_Load()
li_count = 0
li_item = 0
li_time = 1
err = 0
li_starting = 0
'StartClient
End Sub

Private Sub Form_Resize()
'    Form1.Visible = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Winsock2.Close
StopClient
End Sub

'---------------------------------------------------------------------

' Sub MyOPCGroup_DataChange()

' 目的：组中的数值、质量或时间标志改变时，该事件激活

'---------------------------------------------------------------------

'----------- 如果OPC-DA Automation 2.1被安装，使用：

Private Sub MyOPCGroup_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)

 '----------- 设置数据表单元值为数值读

  'Range("B2").Value = CStr(ItemValues(1))

  'Range("C2").Value = Hex(Qualities(1))

  'Range("D2").Value = CStr(TimeStamps(1))
 
  
 ' If li_item = 1 Then
 '   Label1.Caption = CStr(ItemValues(1))
    
'  End If
 ' If li_item = 2 Then
 '   Label7.Caption = CStr(ItemValues(1))
 ' End If
 ' If li_item = 3 Then
 '   Label8.Caption = CStr(ItemValues(1))
 ' End If
 ' If li_item = 4 Then
 '   Label9.Caption = CStr(ItemValues(1))
 ' End If
 ' If li_item = 5 Then
 '   Label12.Caption = CStr(ItemValues(1))
 ' End If
End Sub

'---------------------------------------------------------------------

' Sub worksheet_change()

' 目的：工作表改变时，该事件激活，因此可以写一个新的数值

'---------------------------------------------------------------------

'Private Sub worksheet_change(ByVal Selection As Range)

  '----------- 仅在单元“B3”改变时，写该值

 ' If Selection <> Range("B3") Then Exit Sub

  'Values(1) = Selection.Cells.Value

  '----------- 以不同的模式写新的数值

  'MyOPCGroup.SyncWrite 1, ServerHandles, Values, Errors

'End Sub


Private Sub Timer1_Timer()
    On Error GoTo ErrorH1
    li_time = li_time + 1
    If li_count = 0 Then
        Winsock2.Close
        Winsock2.RemoteHost = "172.16.37.46"
        Winsock2.RemotePort = 5001
        Winsock2.Connect
        If li_item < 6 Then
            li_item = li_item + 1
        End If
        'StartClient
        li_count = 1
        If li_item = 6 Then
            li_item = 0
        End If
    Else
        li_count = 0
        If li_item = 1 Then
            If InStr(Label1.Caption, "-") = 0 And Len(Label1.Caption) > 0 Then
                Winsock2.SendData "11@speed@1@" + Left(Label1.Caption, 4)
            Else
                Winsock2.SendData "11@speed@1@0"
            End If
        End If
        If li_item = 2 Then
            If InStr(Label7.Caption, "-") = 0 And Len(Label7.Caption) > 0 Then
                Winsock2.SendData "11@speed@2@" + Left(Label7.Caption, 4)
            Else
                Winsock2.SendData "11@speed@2@0"
            End If
        End If
        If li_item = 3 Then
            If InStr(Label8.Caption, "-") = 0 And Len(Label8.Caption) > 0 Then
                Winsock2.SendData "11@speed@3@" + Left(Label8.Caption, 4)
            Else
                Winsock2.SendData "11@speed@3@0"
            End If
        End If
        If li_item = 4 Then
            If InStr(Label9.Caption, "-") = 0 And Len(Label9.Caption) > 0 Then
                Winsock2.SendData "11@speed@4@" + Left(Label9.Caption, 4)
            Else
                Winsock2.SendData "11@speed@4@0"
            End If
        End If
        If li_item = 5 Then
            If li_time >= 40 Then
                Winsock2.SendData "11@temperature@1@" + Label12.Caption
                li_time = 0
            End If
        End If
    End If
Exit Sub
ErrorH1:
    Label2.Caption = CStr(Now()) + "socket error"
End Sub

Private Sub Timer2_Timer()
    On Error GoTo ErrorH
   Dim value() As Variant
   Dim err() As Long
   Dim can() As Long
   
   StartClient
   
   If li_err = 1 Then
    Label2.Caption = CStr(Now()) + "connect error"
   
    Exit Sub
   Else
    Label2.Caption = CStr(Now()) + "connect ok"
   End If
   If MyOPCGroup.IsActive Then
        'MyOPCGroup.OPCItems.Item 1, value
        MyOPCGroup.SyncRead 1, 1, ServerHandles1, value, Errors
        Label1.Caption = CStr(value(1))
        MyOPCGroup.SyncRead 1, 1, ServerHandles2, value, Errors
        Label7.Caption = CStr(value(1))
        MyOPCGroup.SyncRead 1, 1, ServerHandles3, value, Errors
        Label8.Caption = CStr(value(1))
        MyOPCGroup.SyncRead 1, 1, ServerHandles4, value, Errors
        Label9.Caption = CStr(value(1))
        MyOPCGroup.SyncRead 1, 1, ServerHandles5, value, Errors
        Label12.Caption = CStr(value(1))
        StopClient
        Exit Sub
   End If
ErrorH:
   Label2.Caption = CStr(Now()) + "read error"
   StopClient
'   On Error Resume Next
 End Sub