Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 1
Option Explicit

' OPC對象的聲明
Dim WithEvents objServer As OPCServer
Attribute objServer.VB_VarHelpID = -1
Dim objGroups As OPCGroups
Dim WithEvents objTestGrp As OPCGroup '事件的對應
Attribute objTestGrp.VB_VarHelpID = -1
Dim objItems As OPCItems
Dim lServerHandles() As Long

Dim lTransID_Rd As Long
Dim lCancelID_Rd As Long
Dim lTransID_Wt As Long
Dim lCancelID_Wt As Long

Sub Connect(strProgID As String, Optional strNode As String)
    
    If objServer Is Nothing Then
        ' 建立一個OPC服務器對象
        Set objServer = New OPCServer
    End If
    
    If objServer.ServerState = OPCDisconnected Then
        ' 連接OPC服務器
        objServer.Connect strProgID, strNode
    End If
    
    If objGroups Is Nothing Then
        ' 建立一個OPC組集合
        Set objGroups = objServer.OPCGroups
    End If
    
    If objTestGrp Is Nothing Then
        ' 添加一個OPC組
        Set objTestGrp = objGroups.Add("TestGrp")
    End If
    
End Sub

Sub Disconnect()
    Dim lErrors() As Long

    If Not objItems Is Nothing Then
        If objItems.Count > 0 Then
            ' 清除OPC項
            objItems.Remove 8, lServerHandles, lErrors
        End If
        Set objItems = Nothing
    End If
    
    If Not objTestGrp Is Nothing Then
        ' 清除OPC組
        objGroups.Remove "TestGrp"
        Set objTestGrp = Nothing
    End If
    
    If Not objGroups Is Nothing Then
        Set objGroups = Nothing
    End If
    
    If Not objServer Is Nothing Then
        If objServer.ServerState <> OPCDisconnected Then
            ' 斷開OPC服務器.
            objServer.Disconnect
        End If
        
        Set objServer = Nothing
    End If
        
End Sub

Sub AddItem()
    Dim strItemIDs(8) As String
    Dim lClientHandles(8) As Long
    Dim lErrors() As Long
    Dim I As Integer

    If objTestGrp Is Nothing Then
        Exit Sub
    End If
    
    If Not objItems Is Nothing Then
        If objItems.Count > 0 Then
            Exit Sub
        End If
    End If
    
    ' 設置組活動狀態
    If DataChgChk.Value = vbChecked Then
        objTestGrp.IsActive = True
    Else
        objTestGrp.IsActive = False
    End If
    ' 啟動組非同期通知
    objTestGrp.IsSubscribed = True
    
    ' 建立OPC項集合
    Set objItems = objTestGrp.OPCItems
    
    ' 生成從TAG1到TAG8的項標識符
    For I = 1 To 8
        strItemIDs(I) = "TAG" & I
        lClientHandles(I) = I
    Next
    ' 添加OPC項
    Call objItems.AddItems(8, strItemIDs, _
        lClientHandles, lServerHandles, lErrors)
    
End Sub

Sub AsyncRead()
    Dim lErrors() As Long

    If objTestGrp Is Nothing Then
        Exit Sub
    End If
    
    If objTestGrp.OPCItems.Count > 0 Then
        ' 非同期讀取
        lTransID_Rd = lTransID_Rd + 1
        objTestGrp.AsyncRead 8, lServerHandles, _
            lErrors, lTransID_Rd, lCancelID_Rd
    End If

End Sub

Sub AsyncWrite(nIndex As Integer, ByRef vtItemValues() As Variant, _
    ByRef lErrors() As Long)
Dim lHandle(1) As Long
    
    If objTestGrp Is Nothing Then
        Exit Sub
    End If
    
    If objTestGrp.OPCItems.Count > 0 Then
        lHandle(1) = lServerHandles(nIndex)
        
        ' 非同期寫入
        lTransID_Wt = lTransID_Wt + 1
        objTestGrp.AsyncWrite 1, lHandle(), vtItemValues, _
                lErrors, lTransID_Wt, lCancelID_Wt
    End If

End Sub

Private Sub DataChgChk_Click()

    If DataChgChk.Value = vbChecked Then
        tmUpdate.Enabled = False
        If Not objTestGrp Is Nothing Then
            objTestGrp.IsActive = True
        End If
    Else
        tmUpdate.Enabled = True
        If Not objTestGrp Is Nothing Then
            objTestGrp.IsActive = False
        End If
    End If
    
End Sub


Private Sub Form_Load()
    ' 初始化全局變量
    DataChgChk.Value = vbUnchecked
    
    tmUpdate.Enabled = True
    tmUpdate.Interval = 1000
    
    lTransID_Rd = 0
    lTransID_Wt = 0
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ' 調用Disconnect子程序
    Call Disconnect

End Sub

Private Sub btnConnect_Click()
    '調用Connect子程序
    Call Connect("OPCJ.SampleServer.1")

End Sub

Private Sub btnAddItem_Click()
    ' 調用AddItem子程序
    Call AddItem
    
End Sub

Private Sub btnQuit_Click()
    ' 卸載窗體
    Unload fmMain

End Sub

Private Sub tmUpdate_Timer()
    ' 非同期讀取
    Call AsyncRead
    
End Sub

Private Sub txbBar_KeyPress(index As Integer, KeyAscii As Integer)
    Dim strData As String
    Dim vtItemData(1) As Variant
    Dim lError() As Long

    ' 是回車鍵?
    If KeyAscii = Asc(vbCr) Then
        ' 得到輸入的字符串
        strData = txbBar(index).Text
        ' 轉換成單精度浮點數
        vtItemData(1) = CSng(strData)
        
        ' 非同期寫入
        Call AsyncWrite(index, vtItemData, lError)
    End If
    
End Sub

Private Sub objTestGrp_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 strBuf As String
    Dim nWidth As Integer
    Dim nHeight As Integer
    Dim nDrawHeight As Integer
    Dim sglScale As Single
    Dim I As Integer
    Dim index As Integer

    ' 棒圖的表示
    For I = 1 To NumItems
        ' 數據的格式化
        strBuf = Format(ItemValues(I), "###.000")
        ' 得到客戶標識符
        index = ClientHandles(I)
        ' 表示數據字符串
        lbBar(index).Caption = strBuf
        ' 計算棒的寬和高
        nWidth = picBar(index).ScaleWidth
        nHeight = picBar(index).ScaleHeight
        sglScale = ItemValues(I) / 100
        nDrawHeight = CInt(nHeight * sglScale)
        ' 清除現棒圖
        picBar(index).Cls
        ' 繪制棒圖
        picBar(index).Line (0, nHeight - nDrawHeight)-(nWidth, nHeight), _
            RGB(255, 0, 0), BF
    Next

End Sub

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

End Sub

Private Sub objTestGrp_DataChange( _
    ByVal TransactionID As Long, ByVal NumItems As Long, _
    ClientHandles() As Long, ItemValues() As Variant, _
    Qualities() As Long, TimeStamps() As Date)
    Dim strBuf As String
    Dim nWidth As Integer
    Dim nHeight As Integer
    Dim nDrawHeight As Integer
    Dim sglScale As Single
    Dim I As Integer
    Dim index As Integer

    ' 棒圖的表示
    For I = 1 To NumItems
        ' 數據的格式化
        strBuf = Format(ItemValues(I), "###.000")
        ' 得到客戶標識符
        index = ClientHandles(I)
        ' 表示數據字符串
        lbBar(index).Caption = strBuf
        ' 計算棒的寬和高
        nWidth = picBar(index).ScaleWidth
        nHeight = picBar(index).ScaleHeight
        sglScale = ItemValues(I) / 100
        nDrawHeight = CInt(nHeight * sglScale)
        ' 清除現棒圖
        picBar(index).Cls
        ' 繪制棒圖
        picBar(index).Line (0, nHeight - nDrawHeight)-(nWidth, nHeight), _
            RGB(255, 0, 0), BF
    Next

End Sub