opcmodule.bas

VB opc程序 欢迎大家看下

Attribute VB_Name = "OPCModule"
Option Explicit

'register
'用GUIDGEN工具生成GUID的字符串
'{5682D6F5-7730-4000-9D0D-3B2E8CD172CB}
Global Const lpCLSID = "{5682D6F5-7730-4000-9D0D-3B2E8CD172CB}"
Global Const lpOPCProgID = "TLSvrRDK.OPCTOOLKIT.2.VB"
Global Const lpOPCDescr = "Tuo Lin RDK by VB6"

Public Type Tag
    m_sTagName As String '//tagname
    m_sDescr As String    '//Description
    m_hHWND As Long       '//Handle
    m_vType As VbVarType  '//type
    
    m_lQuality As Integer '//Quality
    m_ft As FILETIME '   //timestamp
    m_vValue As Variant '  //value
End Type

Global Const MaxCounts = 10

Global TagList(MaxCounts) As Tag

Public Declare Sub GetSystemTimeAsFileTime Lib "kernel32" (lpSystemTimeAsFileTime As FILETIME)
Public Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)

Public Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Public Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Public Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long


Function GetAppPath() As String
  Dim sAppPath  As String
      sAppPath = App.Path
      If Right(sAppPath, 1) <> "\" Then
         sAppPath = sAppPath + "\"
      End If
      GetAppPath = sAppPath
End Function
Function GetAppExeName() As String
  Dim sAppExeName  As String
      sAppExeName = App.EXEName
      sAppExeName = sAppExeName + ".exe"
      GetAppExeName = sAppExeName
End Function
Function OnRegister() As Boolean
'//注册OPC服务器
 Dim bResult As Boolean
 If (TL_RegistryS(lpCLSID, lpOPCProgID, lpOPCDescr, GetAppPath + GetAppExeName) > 0) Then
     bResult = True
     Call MsgBox("注册成功", 64)
Else
     bResult = False
     Call MsgBox("注册失败", 48)
End If
OnRegister = bResult
End Function
Function OnUnRegister() As Boolean
   '//反注册OPC服务器
    Dim bResult As Boolean
    If (TL_UnregisterS(lpCLSID, lpOPCProgID) > 0) Then
        bResult = True
         Call MsgBox("反注册成功", 64)
         Else
         bResult = False
         Call MsgBox("反注册失败", 48)
    End If
    OnUnRegister = bResult
End Function
Function OnInitOpcServer() As Boolean
'    //初始化OPC Server
    Dim bResult As Boolean
    bResult = TL_SetupRegCode("TUOLIN20030713NOTAGCOUNTS")
    bResult = TL_InitOpcServerS(lpCLSID, 500)
    '//设定服务器的分隔符
    TL_SetQualifier (Asc("."))
    Call TL_EnableWriteNotification(AddressOf WriteNotifyCallback)
    Call TL_EnableDisconnectNotification(AddressOf DisconnectProc)
    Call TL_EnableDeviceRead(AddressOf DeviceReadProc)
 
    OnInitOpcServer = bResult

End Function

Sub OnUnInitOpcServer()
 '//结束OPC Server
  Call TL_UnInitOpcServer
End Sub
    
Sub OnAddItem()
'建立点数组
    Dim i As Integer
    For i = 1 To MaxCounts
        TagList(i).m_sTagName = "TAG" + Format(i, "0000")
        TagList(i).m_sDescr = "m_sDescr tag" + Format(i, "0000")
        TagList(i).m_hHWND = -1
        GetSystemTimeAsFileTime TagList(i).m_ft
        TagList(i).m_lQuality = OPC_QUALITY_BAD
        
        Select Case i Mod 4
        Case 0:
            TagList(i).m_vType = vbBoolean
            TagList(i).m_vValue = False
        Case 1:
            TagList(i).m_vType = vbInteger
            TagList(i).m_vValue = 0
        Case 2:
            TagList(i).m_vType = vbSingle
            TagList(i).m_vValue = 0#
        Case 3:
            TagList(i).m_vType = vbString
            TagList(i).m_vValue = "vbString"
        Case Else:
         
        End Select
    Next
'加入opc server
    For i = 1 To MaxCounts
        TagList(i).m_hHWND = TL_CreateTag(TagList(i).m_sTagName, TagList(i).m_vValue, TagList(i).m_lQuality, True)
        '//pTagName->m_sDescr
        '// 101 详见DA 2.04 中的 41页 4.4.6 节
        Call TL_SetTagProperties(TagList(i).m_hHWND, 101, "Item Description", TagList(i).m_sDescr)
    
    Next
    Call MsgBox("additem end", 64)
End Sub

Sub OnDeleteItem()
Dim i As Integer
'删除所有点opc server
    For i = 1 To MaxCounts
        TL_RemoveTag (TagList(i).m_hHWND)
    Next
    Call MsgBox("delete item end", 64)

End Sub
Sub OnUpdateData()
Dim i As Integer
Dim sStr As String
Dim sValue As Variant
Dim sSystime As SYSTEMTIME
Dim sFiletime As FILETIME

'修改所有点opc server
    For i = 1 To MaxCounts
        sStr = "Name :" + TagList(i).m_sTagName + " ,Quality:= " + Str(TagList(i).m_lQuality) + ", Value =" + Str(TagList(i).m_vValue)
        If i = 1 Then
           FrmMain.Text1.Text = "名称  , 通讯质量，值"
        End If
        If i < 100 Then
           FrmMain.Text1.Text = FrmMain.Text1.Text + Chr(13) + Chr(10) + sStr
        End If
        Call TL_UpdateTag(TagList(i).m_hHWND, TagList(i).m_vValue, TagList(i).m_lQuality)
        Call GetSystemTime(sSystime)
        Call SystemTimeToFileTime(sSystime, sFiletime)
        Call TL_UpdateTagWithTimeStamp(TagList(i).m_hHWND, TagList(i).m_vValue, TagList(i).m_lQuality, sFiletime)
      
        '用于演示读数据功能
        Call TL_ReadTag(TagList(i).m_hHWND, sValue)
        FrmMain.Caption = CStr(sValue)
    Next
End Sub

Sub OnRandomData()
'产生随机数据
 Dim i As Integer
 Dim iRand As Single
    For i = 1 To MaxCounts
        iRand = Rnd(1) * 1000
        'If (iRand > 400) Then
        '    TagList(i).m_lQuality = OPC_QUALITY_UNCERTAIN
        '    If (iRand > 800) Then
        '    TagList(i).m_lQuality = OPC_QUALITY_GOOD
        '    End If
        '    Else
        '    TagList(i).m_lQuality = OPC_QUALITY_BAD
        'End If
        TagList(i).m_lQuality = OPC_QUALITY_GOOD
        Select Case i Mod 4
        Case 0:
            If (iRand > 500) Then
               TagList(i).m_vValue = False
               Else
               TagList(i).m_vValue = True
            End If
        Case 1:
            TagList(i).m_vValue = CInt(iRand)
        Case 2:
            TagList(i).m_vValue = iRand
        Case 3:
            TagList(i).m_vValue = Format(iRand, "###0.00")
        Case Else:
        End Select
    Next
    DoEvents
End Sub