fmain.frm

OPC 开发工具包2.0 OPC工具包是用来简化OPC规范服务器开发的工具包

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form fMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "OPC DA Server Demo by VB(Agilewill software co.ltd)"
   ClientHeight    =   6615
   ClientLeft      =   6540
   ClientTop       =   5565
   ClientWidth     =   9510
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   441
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   634
   StartUpPosition =   2  'CenterScreen
   Begin MSComctlLib.TreeView TreeView1 
      Height          =   6585
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   2355
      _ExtentX        =   4154
      _ExtentY        =   11615
      _Version        =   393217
      LineStyle       =   1
      Style           =   7
      Appearance      =   1
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   5640
      Top             =   1800
   End
   Begin MSComctlLib.ListView ListView1 
      Height          =   6615
      Left            =   2400
      TabIndex        =   0
      Top             =   0
      Width           =   7080
      _ExtentX        =   12488
      _ExtentY        =   11668
      View            =   3
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      AllowReorder    =   -1  'True
      FlatScrollBar   =   -1  'True
      FullRowSelect   =   -1  'True
      _Version        =   393217
      Icons           =   "ImageList1"
      SmallIcons      =   "ImageList1"
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   4
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "名称"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   1
         Text            =   "值"
         Object.Width           =   5080
      EndProperty
      BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   2
         Text            =   "质量"
         Object.Width           =   1411
      EndProperty
      BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   3
         Text            =   "时间戳"
         Object.Width           =   3175
      EndProperty
   End
   Begin VB.Menu Operate 
      Caption         =   "操作（&O）"
      Begin VB.Menu Register 
         Caption         =   "注册服务器"
      End
      Begin VB.Menu Unregister 
         Caption         =   "注销服务器"
      End
      Begin VB.Menu Shutdown 
         Caption         =   "关闭服务器（&D）"
      End
   End
   Begin VB.Menu About 
      Caption         =   "关于（&A）"
   End
End
Attribute VB_Name = "fMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private InitOK As Boolean
Private Seed As Integer


Private Function SystemTimeToString(st As SYSTEMTIME) As String
    Dim y, m, d, hh, mm, ss, ms
    
    y = st.wYear
    m = st.wMonth
    d = st.wDay
    hh = st.wHour
    mm = st.wMinute
    ss = st.wSecond
    ms = st.wMilliseconds
    
    SystemTimeToString = CStr(y) + "-" + CStr(m) + "-" + CStr(d) + " " + CStr(hh) + ":" + CStr(mm) + ":" + CStr(ss)
    
End Function

Private Function CheckCommandParm(parm As String) As Boolean
    Dim SvrPath As String
    SvrPath = App.Path + "\" + App.EXEName + ".EXE"
    If LCase(parm) = "-regserver" Then
        If RegServer(ClsID, ProgID, Description, SvrPath) Then
            MsgBox ("Server register success...")
        Else
            MsgBox ("Server register fail...")
        End If
        CheckCommandParm = True
    End If
    If LCase(parm) = "-unregserver" Then
        If UnregServer(ClsID, ProgID) Then
            MsgBox ("Server unregister success...")
        Else
            MsgBox ("Server unregister fail...")
        End If
        CheckCommandParm = True
    End If
    CheckCommandParm = False
End Function
Private Sub AddTags()
    Dim I, J As Integer
    Dim num, Handle
    Dim rNode, pNode As Node
    Dim st As SYSTEMTIME
    Dim ft As FILETIME
    GetSystemTime st
    SystemTimeToFileTime st, ft
    
    Tagcount = 0
    TreeView1.Nodes.Clear
    
    Set rNode = TreeView1.Nodes.Add(, , "r", "VBDEMO")
    Handle = RegTag(0, "Integer", 0, 192, False)
    If Handle > 0 Then
        Set pNode = TreeView1.Nodes.Add("r", tvwChild, "I", "Integer")
        For I = 0 To 7
            Tagcount = Tagcount + 1
            TagList(Tagcount).TagID = "TagInt" + CStr(I)
            TagList(Tagcount).TagType = vbInteger
            TagList(Tagcount).TagQuality = 0
            TagList(Tagcount).TagValue = 0
            TagList(Tagcount).TagFt = ft
            TagList(Tagcount).TagHandle = RegTagEx(Handle, TagList(Tagcount).TagID, vbInteger, 3)
        Next
    End If
    Handle = RegTag(0, "String", 0, 192, False)
    If Handle > 0 Then
        Set pNode = TreeView1.Nodes.Add("r", tvwChild, "S", "String")
        For I = 0 To 7
            Tagcount = Tagcount + 1
            TagList(Tagcount).TagID = "TagString" + CStr(I)
            TagList(Tagcount).TagType = vbString
            TagList(Tagcount).TagQuality = 0
            TagList(Tagcount).TagValue = "Agilewill OPC SDK"
            TagList(Tagcount).TagFt = ft
            TagList(Tagcount).TagHandle = RegTagEx(Handle, TagList(Tagcount).TagID, vbString, 3)
        Next
    End If
    
    Handle = RegTag(0, "Bool", 0, 192, False)
    If Handle > 0 Then
        Set pNode = TreeView1.Nodes.Add("r", tvwChild, "B", "Bool")
        For I = 0 To 7
            Tagcount = Tagcount + 1
            TagList(Tagcount).TagID = "TagBool" + CStr(I)
            TagList(Tagcount).TagType = vbBoolean
            TagList(Tagcount).TagQuality = 0
            TagList(Tagcount).TagValue = False
            TagList(Tagcount).TagFt = ft
            TagList(Tagcount).TagHandle = RegTagEx(Handle, TagList(Tagcount).TagID, vbBoolean, 3)
        Next
    End If
    
    Handle = RegTag(0, "Float", 0, 192, False)
    If Handle > 0 Then
        Set pNode = TreeView1.Nodes.Add("r", tvwChild, "F", "Float")
    
        For I = 0 To 7
            Tagcount = Tagcount + 1
            TagList(Tagcount).TagID = "TagFloat" + CStr(I)
            TagList(Tagcount).TagType = vbDouble
            TagList(Tagcount).TagQuality = 0
            TagList(Tagcount).TagValue = 0#
            TagList(Tagcount).TagFt = ft
            TagList(Tagcount).TagHandle = RegTagEx(Handle, TagList(Tagcount).TagID, vbDouble, 3)
        Next
    End If
    rNode.Expanded = True
End Sub
'硬件设备数据模拟和服务器地址空间数据刷新
Private Sub Simulate()
    Dim I, J As Integer
    Dim pNode As Node
    Dim st As SYSTEMTIME
    Dim ft As FILETIME
    
    GetSystemTime st
    SystemTimeToFileTime st, ft
    
    Seed = Seed + 1
    If Seed > 100 Then
        Seed = 0
    End If
    
    For I = 0 To 3
        For J = 1 To 4
            Select Case TagList(I * 8 + J).TagType
                Case vbBoolean
                    If Seed Mod 2 = 0 Then
                        TagList(I * 8 + J).TagValue = False
                    Else
                        TagList(I * 8 + J).TagValue = True
                    End If
                Case vbInteger
                    TagList(I * 8 + J).TagValue = Seed
                Case vbString
                    TagList(I * 8 + J).TagValue = CStr(Seed)
                Case Else
                    TagList(I * 8 + J).TagValue = 100 * Sin(Seed * 3.14 / 50)
            End Select
            TagList(I * 8 + J).TagQuality = 192
            TagList(I * 8 + J).TagFt = ft
            Call UpdateTag(TagList(I * 8 + J).TagHandle, TagList(I * 8 + J).TagValue, TagList(I * 8 + J).TagQuality)
        Next
    Next
    If TreeView1.SelectedItem Is Nothing Then
    Else
        Call TreeView1_NodeClick(TreeView1.SelectedItem)
    End If
    
End Sub
Private Function CreateOPCServer() As Boolean
    'ActiveCode "", ""
    If CreateServer(ClsID, 1000) Then
        InitOK = True
        Call SetServerNotify(AddressOf ServerNotify)
        Call SetWriteCallback(AddressOf WriteCallback)
        AddTags
        SetServerState (1)
        Timer1.Enabled = True
    Else
        InitOK = False
    End If

End Function
Private Sub FreeOPCServer()
    Dim b As Boolean

    If InitOK Then
        Call SetServerNotify(0)
        Call SetWriteCallback(0)
        Call FreeServer
    End If
End Sub

Private Sub Form_Load()
    Dim str As String
    ScaleWidth = 640
    ScaleHeight = 480
    ScaleMode = 3
    str = Command()
    If CheckCommandParm(str) Then
        Shutdown_Click
    Else
        Call CreateOPCServer
        ListView1.View = lvwReport
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    FreeOPCServer
End Sub

Private Sub ListView1_BeforeLabelEdit(Cancel As Integer)

End Sub

Private Sub Register_Click()
    Dim SvrPath As String
    SvrPath = App.Path + "\" + App.EXEName + ".EXE"
    If RegServer(ClsID, ProgID, Description, SvrPath) Then
        MsgBox ("Server register success...")
    Else
        MsgBox ("Server register fail...")
    End If
End Sub

Private Sub Timer1_Timer()
    Simulate
End Sub
 
Private Sub About_Click()
    fAbout.Show
End Sub
 
Private Sub Shutdown_Click()
  Unload Me
End Sub


Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim I As Integer
    Dim li As ListItem
    Dim st As SYSTEMTIME
    Dim ft As FILETIME
    Dim n As Node
    
    Dim dt As Date
    
    If Node.Key = "" Then
        Return
    End If
    
    
    ListView1.ListItems.Clear
    
    Select Case Node.Key
        Case "I"
            For I = 1 To 8
                Set li = ListView1.ListItems.Add(, , TagList(I).TagID)
                li.SubItems(1) = TagList(I).TagValue
                li.SubItems(2) = CStr(TagList(I).TagQuality)
                FileTimeToLocalFileTime TagList(I).TagFt, ft
                FileTimeToSystemTime ft, st
                li.SubItems(3) = SystemTimeToString(st)
            Next
        Case "S"
            For I = 9 To 16
                Set li = ListView1.ListItems.Add(, , TagList(I).TagID)
                li.SubItems(1) = TagList(I).TagValue
                li.SubItems(2) = CStr(TagList(I).TagQuality)
                FileTimeToLocalFileTime TagList(I).TagFt, ft
                FileTimeToSystemTime ft, st
                li.SubItems(3) = SystemTimeToString(st)
            Next
        Case "B"
            For I = 17 To 24
                Set li = ListView1.ListItems.Add(, , TagList(I).TagID)
                li.SubItems(1) = TagList(I).TagValue
                li.SubItems(2) = CStr(TagList(I).TagQuality)
                FileTimeToLocalFileTime TagList(I).TagFt, ft
                FileTimeToSystemTime ft, st
                li.SubItems(3) = SystemTimeToString(st)
            Next
        Case "F"
            For I = 25 To 32
                Set li = ListView1.ListItems.Add(, , TagList(I).TagID)
                li.SubItems(1) = TagList(I).TagValue
                li.SubItems(2) = CStr(TagList(I).TagQuality)
                FileTimeToLocalFileTime TagList(I).TagFt, ft
                FileTimeToSystemTime ft, st
                li.SubItems(3) = SystemTimeToString(st)
            Next
    End Select
    
End Sub

Private Sub Unregister_Click()
    If UnregServer(ClsID, ProgID) Then
        MsgBox ("Server unregister success...")
    Else
        MsgBox ("Server unregister fail...")
    End If
End Sub