barmeter.ctl

OPC应用程序入门

VERSION 5.00
Begin VB.UserControl BarMeter 
   ClientHeight    =   3240
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3912
   FillStyle       =   0  'Solid
   LockControls    =   -1  'True
   PropertyPages   =   "BarMeter.ctx":0000
   ScaleHeight     =   3240
   ScaleWidth      =   3912
   ToolboxBitmap   =   "BarMeter.ctx":002D
End
Attribute VB_Name = "BarMeter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Public Event DataChange2()

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long

' OPC对象
Dim WithEvents objMyOpcServer As OPCServer
Attribute objMyOpcServer.VB_VarHelpID = -1
Dim WithEvents objMyOpcGroup As OPCGroup
Attribute objMyOpcGroup.VB_VarHelpID = -1
Dim objMyOpcGroups As OPCGroups

' 棒图的方向
Public Enum OpcBarDirection
    opcbarUp = 0    ' 从下至上
    opcbarDown = 1  ' 从上至下
    opcbarRight = 2 ' 从左至右
    opcbarLeft = 3  ' 从右至左
End Enum

' 属性
Dim dValue As Double
Dim dValueMax As Double
Dim dValueMin As Double
Dim ocMainColor As OLE_COLOR
Dim ocBackColor As OLE_COLOR
Dim ocOverMaxColor As OLE_COLOR
Dim obdDirection As OpcBarDirection
Dim bAutoLink As Boolean
Dim strProgID As String
Dim strItemID As String

' 内部工作变量
Dim g_bConnect As Boolean   ' 连接标志
Dim g_lNowTime As Long      ' 本次事件的发生时间
Dim g_lOldTime As Long      ' 上次事件的发生时间
Dim g_dPf As Double         ' 事件数

' 属性的初期值
Const conDefaultValue As Double = 0
Const conDefaultValueMax As Double = 1
Const conDefaultValueMin As Double = -1
Const conDefaultMainColor As Long = &HFF0000
Const conDefaultBackColor As Long = &HFFFFFF
Const conDefaultOverMaxColor As Long = &HFF
Const conDefaultAutoLink As Boolean = False
Const conDefaultProgID As String = "OPCJ.DADemoServer.1"
Const conDefaultItemID As String = "SV1"

Public Sub Connect()
    ' 连接OPC服务器
    If Ambient.UserMode Then
        ' 连接OPC服务器仅限于运行模式
        Call OpcConnect(strProgID, strItemID)
    End If
End Sub

Public Sub Disconnect()
    ' 断开OPC服务器
    Call OpcDisConnect
End Sub

Private Sub BarPaint()
    ' 描绘棒图
    Dim dPercent As Double  ' Rate of meter
    Dim dPercent2 As Double
    
    If (ValueMin >= ValueMax Or Value <= ValueMin) Then
        ' 没有上下限或超出下限
        Line (0, 0)-(ScaleWidth, ScaleHeight), BackColor, BF
        Exit Sub
    End If
    
    If (Value > ValueMax) Then
        ' 超出上限
        Line (0, 0)-(ScaleWidth, ScaleHeight), OverMaxColor, BF
        Exit Sub
    End If

    ' 在上下限内
    dPercent = (Value - ValueMin) / (ValueMax - ValueMin)
    dPercent2 = 1 - dPercent
    
    Select Case DrawDirection
        Case opcbarUp
            ' 从下至上
            Line (0, 0)-(ScaleWidth, ScaleHeight * dPercent2), BackColor, BF
            Line (0, ScaleHeight * dPercent2)-(ScaleWidth, ScaleHeight), MainColor, BF
        Case opcbarDown
            ' 从上至下
            Line (0, ScaleHeight * dPercent)-(ScaleWidth, ScaleHeight), BackColor, BF
            Line (0, 0)-(ScaleWidth, ScaleHeight * dPercent), MainColor, BF
        Case opcbarRight
            ' 从左至右
            Line (ScaleWidth * dPercent, 0)-(ScaleWidth, ScaleHeight), BackColor, BF
            Line (0, 0)-(ScaleWidth * dPercent, ScaleHeight), MainColor, BF
        Case opcbarLeft
            ' 从右至左
            Line (0, 0)-(ScaleWidth * dPercent2, ScaleHeight), BackColor, BF
            Line (ScaleWidth * dPercent2, 0)-(ScaleWidth, ScaleHeight), MainColor, BF
        Case Else
            ' 错误
            Line (0, 0)-(ScaleWidth, ScaleHeight), BackColor, BF
            Line (0, 0)-(ScaleWidth, ScaleHeight), OverMaxColor
            Line (0, ScaleHeight)-(ScaleWidth, 0), OverMaxColor
    End Select
End Sub

Private Sub objMyOpcServer_ServerShutDown(ByVal Reason As String)
    ' OPC服务器关机要求的处理
    Call Disconnect

    MsgBox Title:=Extender.Name, _
        Prompt:="OPC服务器关机。" & vbCr & """" & Reason & """", _
        Buttons:=vbInformation
End Sub

Private Sub objMyOpcGroup_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, _
        ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)
    ' 数据变化事件的处理
    ' 记录时间和次数
    g_lOldTime = g_lNowTime
    g_lNowTime = timeGetTime
    g_dPf = g_dPf + 1

    ' 读取数据
    Value = ItemValues(LBound(ItemValues))

    ' 发生DataChange2事件
    RaiseEvent DataChange2
End Sub

Private Sub UserControl_Initialize()
    ' 内部工作变量的初始化
    g_bConnect = False
    g_lNowTime = 0
    g_lOldTime = 0
    g_dPf = 0

    ' 设定时间单位
    timeBeginPeriod 1
End Sub

Private Sub UserControl_InitProperties()
    ' 属性的初始化
    dValue = conDefaultValue
    dValueMax = conDefaultValueMax
    dValueMin = conDefaultValueMin
    
    ocMainColor = conDefaultMainColor
    ocBackColor = conDefaultBackColor
    ocOverMaxColor = conDefaultOverMaxColor
    
    obdDirection = opcbarUp
    
    bAutoLink = conDefaultAutoLink
    strProgID = conDefaultProgID
    strItemID = conDefaultItemID

    If AutoLink Then
        ' 自动连接
        Call Connect
    End If
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    ' 保存属性的读取
    Value = PropBag.ReadProperty("Value", conDefaultValue)
    ValueMax = PropBag.ReadProperty("ValueMax", conDefaultValueMax)
    ValueMin = PropBag.ReadProperty("ValueMin", conDefaultValueMin)

    MainColor = PropBag.ReadProperty("MainColor", conDefaultMainColor)
    BackColor = PropBag.ReadProperty("BackColor", conDefaultBackColor)
    OverMaxColor = PropBag.ReadProperty("OverMaxColor", conDefaultOverMaxColor)
    
    DrawDirection = PropBag.ReadProperty("DrawDirection", opcbarUp)
    
    AutoLink = PropBag.ReadProperty("AutoLink", conDefaultAutoLink)
    ProgID = PropBag.ReadProperty("ProgID", conDefaultProgID)
    ItemID = PropBag.ReadProperty("ItemID", conDefaultItemID)

    If AutoLink Then
        ' 自动连接
        Call Connect
    End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    ' 属性的保存
    PropBag.WriteProperty "Value", Value, conDefaultValue
    PropBag.WriteProperty "ValueMax", ValueMax, conDefaultValueMax
    PropBag.WriteProperty "ValueMin", ValueMin, conDefaultValueMin

    PropBag.WriteProperty "MainColor", MainColor, conDefaultMainColor
    PropBag.WriteProperty "BackColor", BackColor, conDefaultBackColor
    PropBag.WriteProperty "OverMaxColor", OverMaxColor, conDefaultOverMaxColor
    
    PropBag.WriteProperty "DrawDirection", DrawDirection, opcbarUp

    PropBag.WriteProperty "AutoLink", AutoLink, conDefaultAutoLink
    PropBag.WriteProperty "ProgID", ProgID, conDefaultProgID
    PropBag.WriteProperty "ItemID", ItemID, conDefaultItemID
End Sub

Private Sub UserControl_Terminate()
    ' 切断OPC服务器
    Call Disconnect
    
    ' 结束时间单位的设定
    timeEndPeriod 1
End Sub

Private Sub UserControl_Paint()
    ' 描绘棒图
    Call BarPaint
End Sub

' 现在值
Public Property Get Value() As Double
    Value = dValue
End Property

Public Property Let Value(ByVal dNewValue As Double)
    dValue = dNewValue
    PropertyChanged "Value"
    Call BarPaint
End Property

' 最大值
Public Property Get ValueMax() As Double
    ValueMax = dValueMax
End Property

Public Property Let ValueMax(ByVal dNewValue As Double)
    dValueMax = dNewValue
    PropertyChanged "ValueMax"
    Call BarPaint
End Property

' 最小值
Public Property Get ValueMin() As Double
    ValueMin = dValueMin
End Property

Public Property Let ValueMin(ByVal dNewValue As Double)
    dValueMin = dNewValue
    PropertyChanged "ValueMin"
    Call BarPaint
End Property

' 棒的颜色
Public Property Get MainColor() As OLE_COLOR
    MainColor = ocMainColor
End Property

Public Property Let MainColor(ByVal ocNewValue As OLE_COLOR)
    ocMainColor = ocNewValue
    PropertyChanged "MainColor"
    Call BarPaint
End Property

' 背景的颜色
Public Property Get BackColor() As OLE_COLOR
    BackColor = ocBackColor
End Property

Public Property Let BackColor(ByVal ocNewValue As OLE_COLOR)
    ocBackColor = ocNewValue
    PropertyChanged "BackColor"
    Call BarPaint
End Property

' 超出上限时棒的颜色
Public Property Get OverMaxColor() As OLE_COLOR
    OverMaxColor = ocOverMaxColor
End Property

Public Property Let OverMaxColor(ByVal ocNewValue As OLE_COLOR)
    ocOverMaxColor = ocNewValue
    PropertyChanged "OverMaxColor"
    Call BarPaint
End Property

' 棒的方向
Public Property Get DrawDirection() As OpcBarDirection
    DrawDirection = obdDirection
End Property

Public Property Let DrawDirection(ByVal odbNewValue As OpcBarDirection)
    obdDirection = odbNewValue
    PropertyChanged "DrawDirection"
    Call BarPaint
End Property

' 是否自动连接?
Public Property Get AutoLink() As Boolean
    AutoLink = bAutoLink
End Property

Public Property Let AutoLink(ByVal bNewValue As Boolean)
    bAutoLink = bNewValue
    PropertyChanged "AutoLink"
End Property

' OPC的设置
Public Property Get ProgID() As String
    ProgID = strProgID
End Property

Public Property Let ProgID(ByVal strNewValue As String)
    strProgID = strNewValue
    PropertyChanged "ProgID"
End Property

Public Property Get ItemID() As String
    ItemID = strItemID
End Property

Public Property Let ItemID(ByVal strNewValue As String)
    strItemID = strNewValue
    PropertyChanged "ItemID"
End Property

' 读取数据的时间间隔(仅用于运行模式)
Public Property Get Time() As Long
    ' In this procedure, it is no check in this program,
    ' though there is possibility being returned for a theoretical strange value.
    Time = Abs(g_lNowTime - g_lOldTime)
End Property

Public Property Let Time(ByVal lNewValue As Long)
    ' 错误，只读用属性
    Err.Raise Number:=383
End Property

' 读取数据的次数(仅用于运行模式)
Public Property Get Pf() As Double
    Pf = g_dPf
End Property

Public Property Let Pf(ByVal dNewValue As Double)
    ' 错误，只读用属性
    Err.Raise Number:=383
End Property

Public Sub ShowAboutBox()
Attribute ShowAboutBox.VB_UserMemId = -552
    ' 版本信息
    dlgAbout.Show vbModal
    Unload dlgAbout
    Set dlgAbout = Nothing
End Sub

Private Sub OpcConnect(ByVal strProgID As String, ByVal strItemID As String)
    Dim myOpcServer As OPCServer
    Dim myOpcItems As OPCItems
    Dim myOpcGroups As OPCGroups
    Dim myOpcGroup As OPCGroup
    Dim strNode As String
    Dim lLength As Long
    
    ' 连接OPC服务器
    If g_bConnect Then Exit Sub
    
    Set myOpcServer = New OPCServer
    
    If Left(strProgID, 2) = "\\" Then
        ' 连接远程OPC服务器
        lLength = InStr(3, strProgID, "\")
        If lLength = 0 Then
            MsgBox Title:=Extender.Name, _
                Prompt:="The format of node is incorrect." & vbCr & "(" & strProgID & ")", _
                Buttons:=vbExclamation
            Set myOpcServer = Nothing
            Exit Sub
        End If
        strNode = Left(strProgID, lLength - 1)
        strProgID = Right(strProgID, Len(strProgID) - lLength)
        
        On Error GoTo ConnectError
        myOpcServer.Connect strProgID, strNode
        On Error GoTo 0
    Else
        ' 连接本地OPC服务器
        On Error GoTo ConnectError
        myOpcServer.Connect strProgID
        On Error GoTo 0
    End If
    
    ' OPC组的添加
    Set myOpcGroups = myOpcServer.OPCGroups
    Set myOpcGroup = myOpcGroups.Add("MyGroup")
    myOpcGroup.UpdateRate = 10          ' 设置更新周期为10毫秒。
    myOpcGroup.IsSubscribed = True      ' 使数据变化事件有效。
    Set myOpcItems = myOpcGroup.OPCItems
    
    Dim ItemServerHandles() As Long
    Dim ItemServerErrors() As Long
    Dim RequestedDataTypes(1) As Integer
    Dim AccessPaths As Variant
    Dim ClientHandles(1) As Long
    Dim OPCItemIDs(1) As String

    ' OPC项的添加
    OPCItemIDs(1) = strItemID
    ClientHandles(1) = 1
    RequestedDataTypes(1) = vbDouble
    myOpcItems.AddItems 1, OPCItemIDs, ClientHandles, ItemServerHandles, _
        ItemServerErrors, RequestedDataTypes, AccessPaths
    
    Set objMyOpcServer = myOpcServer
    Set objMyOpcGroups = myOpcGroups
    Set objMyOpcGroup = myOpcGroup

    g_bConnect = True
    Exit Sub

ConnectError:
    ' OPC服务器连接错误
    Set myOpcServer = Nothing
    
    strString = "ProgID is incorrect."
    MsgBox Title:=Extender.Name, _
        Prompt:=strString & vbCr & "(" & ProgID & ")", _
        Buttons:=vbExclamation
End Sub

Private Sub OpcDisConnect()
    ' 切断OPC服务器
    If Not g_bConnect Then Exit Sub
    
    objMyOpcGroups.RemoveAll
    objMyOpcServer.Disconnect
    
    Set objMyOpcGroup = Nothing
    Set objMyOpcGroups = Nothing
    Set objMyOpcServer = Nothing
    
    g_bConnect = False
End Sub