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，創(chuàng)建組和添加條目

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

Sub StartClient()
   On Error GoTo ErrorHandler
  '----------- 可以自由選擇ClientHandle和GroupName
  'On Error Resume Next
  ClientHandles(1) = 1
  GroupName = "MyGroup"
  '----------- 從單元“A1”得到ItemID
  NodeName = "zdh"
  '----------- 得到一個(gè)OPC服務(wù)器的實(shí)例
  Set MyOPCServer = New OPCServer
  MyOPCServer.Connect ServerName, NodeName
  Set MyOPCGroupColl = MyOPCServer.OPCGroups
  '----------- 為添加組設(shè)置缺省的激活狀態(tài)
  MyOPCGroupColl.DefaultGroupIsActive = True
  '----------- 添加組至收集
  Set MyOPCGroup = MyOPCGroupColl.Add(GroupName)
  Set MyOPCItemColl = MyOPCGroup.OPCItems
  '----------- 添加一個(gè)條目、返回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()

' 目的：從服務(wù)器釋放對(duì)象并且斷開連接

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

Sub StopClient()

  '----------- 釋放組和服務(wù)器對(duì)象

  MyOPCGroupColl.RemoveAll

  '----------- 與服務(wù)器斷開連接并且清除

  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()

' 目的：組中的數(shù)值、質(zhì)量或時(shí)間標(biāo)志改變時(shí)，該事件激活

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

'----------- 如果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)

 '----------- 設(shè)置數(shù)據(jù)表單元值為數(shù)值讀

  '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()

' 目的：工作表改變時(shí)，該事件激活，因此可以寫一個(gè)新的數(shù)值

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

'Private Sub worksheet_change(ByVal Selection As Range)

  '----------- 僅在單元“B3”改變時(shí)，寫該值

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

  'Values(1) = Selection.Cells.Value

  '----------- 以不同的模式寫新的數(shù)值

  '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