form1.frm

VB 关于 opc的源码

    
    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的项标识符
        strItemIDs(1) = "flag/Counter"
        strItemIDs(2) = "flag/Counter"
        strItemIDs(3) = "flag/Counter"
        strItemIDs(4) = "flag/Counter"
        strItemIDs(5) = "flag/Counter"
        strItemIDs(6) = "flag/Counter"
        strItemIDs(7) = "flag / Counter" '"8716(1,9600,1)/i"
        strItemIDs(8) = "flag/Counter"

    For I = 1 To 8
        lClientHandles(I) = I
    Next
    ' 添加OPC项
    Call objItems.AddItems(8, strItemIDs, _
        lClientHandles, lServerHandles, lErrors)
        objItems(1).IsActive = False
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 Command1_Click()
Call AsyncRead
End Sub

Private Sub Command2_Click()
Call SyncRead
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("青智通讯驱动OPC")

End Sub

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

Private Sub btnQuit_Click()
Disconnect
    
    ' 卸载窗体
    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 / 100)
        ' 清除现棒图
        picBar(index).Cls
        ' 绘制棒图
        picBar(index).Line (0, nHeight - nDrawHeight)-(nWidth, nHeight), _
            RGB(255, 0, 0), BF
    Next

End Sub
Sub SyncRead()
    Dim lErrors() 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

    If objTestGrp Is Nothing Then
        Exit Sub
    End If
    
    If objTestGrp.OPCItems.Count > 0 Then
        ' 非同期读取
        lTransID_Rd = lTransID_Rd + 1
        objTestGrp.SyncRead OPCDevice, 8, lServerHandles, Values, lErrors, Qualities, TimeStamps
    
        For I = 1 To 8
        ' 数据的格式化
        strBuf = Format(Values(I), "###.000")
        ' 表示数据字符串
        lbBar(I).Caption = strBuf
        ' 计算棒的宽和高
        nWidth = picBar(I).ScaleWidth
        nHeight = picBar(I).ScaleHeight
        sglScale = Values(I) / 100
        nDrawHeight = CInt(nHeight * sglScale / 100)
        ' 清除现棒图
        picBar(I).Cls
        ' 绘制棒图
        picBar(I).Line (0, nHeight - nDrawHeight)-(nWidth, nHeight), _
            RGB(255, 0, 0), BF
    Next
    
    
    
    End If


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