form1.frm

这是用VB编写的OPC应用程序代码。可以用于连接OPC数据服务器

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