frmmain.frm

VBOPCClient.rar vb编写的opc客户端源程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmMain 
   Caption         =   "OPC演示程序"
   ClientHeight    =   4275
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   4665
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4275
   ScaleWidth      =   4665
   StartUpPosition =   3  'Windows Default
   Begin MSComctlLib.ListView lvListView 
      Height          =   2055
      Left            =   120
      TabIndex        =   1
      Top             =   360
      Width           =   1455
      _ExtentX        =   2566
      _ExtentY        =   3625
      View            =   2
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      FullRowSelect   =   -1  'True
      HotTracking     =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      NumItems        =   0
   End
   Begin MSComctlLib.ImageList lvwbImageList 
      Left            =   2880
      Top             =   360
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":030A
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   345
      Left            =   2160
      Top             =   360
   End
   Begin MSComctlLib.StatusBar sbStatusBar 
      Align           =   2  'Align Bottom
      Height          =   270
      Left            =   0
      TabIndex        =   0
      Top             =   4005
      Width           =   4665
      _ExtentX        =   8229
      _ExtentY        =   476
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   3
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   1
            Object.Width           =   2593
            Text            =   "Status"
            TextSave        =   "Status"
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   6
            AutoSize        =   2
            TextSave        =   "2004-4-26"
         EndProperty
         BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Style           =   5
            AutoSize        =   2
            TextSave        =   "11:40"
         EndProperty
      EndProperty
   End
   Begin MSComDlg.CommonDialog dlgCommonDialog 
      Left            =   1740
      Top             =   1350
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.ImageList lvwsImageList 
      Left            =   3600
      Top             =   360
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmMain.frx":0464
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件"
      Begin VB.Menu mnuConnect 
         Caption         =   "连接OPC服务器"
      End
      Begin VB.Menu mnuDisconnect 
         Caption         =   "断开连接"
      End
      Begin VB.Menu mnuSplit 
         Caption         =   "-"
      End
      Begin VB.Menu mnuAddItem 
         Caption         =   "添加标签"
      End
      Begin VB.Menu mnuRemoveItem 
         Caption         =   "移除标签"
      End
      Begin VB.Menu mnuSplit2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuReadItem 
         Caption         =   "读标签"
      End
      Begin VB.Menu mnuWriteItem 
         Caption         =   "写标签"
      End
   End
   Begin VB.Menu mnuView 
      Caption         =   "查看"
      Begin VB.Menu mnuViewStatusBar 
         Caption         =   "状态栏"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助"
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const NAME_COLUMN = 0
Const TYPE_COLUMN = 1
Const SIZE_COLUMN = 2
Const DATE_COLUMN = 3
  
Dim mServerName(100) As Byte
Dim mMachineName(100) As Byte
Dim mGroupName(100) As Byte


Dim mbReturn As Boolean
Dim mListItem As listItem
Public Sub Disconnect()
    gMainForm.Timer1.Enabled = False
    
    If gConnectionHandle = -1 Then Exit Sub
    
    If gGroupHandle <> -1 Then
        Dim i, j As Integer
        Dim pItem As CItem
        Dim strKey As String
        gMainForm.lvListView.ListItems.Clear
        For Each pItem In g_ItemCol
            HF_RemoveItem gConnectionHandle, gGroupHandle, pItem.itemHandle
            strKey = "k" & Str(pItem.itemHandle)
            g_ItemCol.Remove strKey
        Next
        HF_RemoveGroup gConnectionHandle, gGroupHandle
    End If
    
    HF_Disconnect (gConnectionHandle)
    
    Set mListItem = Nothing
    gConnectionHandle = -1
    gGroupHandle = -1
   
    gMainForm.mnuConnect.Enabled = True
    gMainForm.mnuDisconnect.Enabled = False
    gMainForm.mnuAddItem.Enabled = False
    gMainForm.mnuRemoveItem.Enabled = False
    gMainForm.mnuReadItem.Enabled = False
    gMainForm.mnuWriteItem.Enabled = False
End Sub


Private Sub Form_Load()
    Set mListItem = Nothing
    gMainForm.mnuConnect.Enabled = True
    gMainForm.mnuDisconnect.Enabled = False
    gMainForm.mnuAddItem.Enabled = False
    gMainForm.mnuRemoveItem.Enabled = False
    gMainForm.mnuReadItem.Enabled = False
    gMainForm.mnuWriteItem.Enabled = False

    gConnectionHandle = -1
    gGroupHandle = -1
    
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)

    lvListView.View = lvwReport
    
    lvListView.ColumnHeaders.Add 1, "标签名称", "标签名称", 1500
    lvListView.ColumnHeaders.Add 2, "数据类型", "数据类型", 1000
    lvListView.ColumnHeaders.Add 3, "值", "值", 2200
    lvListView.ColumnHeaders.Add 4, "时间", "时间", 1900
    lvListView.ColumnHeaders.Add 5, "质量", "质量", 1900

    lvListView.Icons = lvwbImageList
    lvListView.SmallIcons = lvwsImageList
    
    mbReturn = HF_Init()
    
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Disconnect
End Sub

Private Sub Form_Unload(Cancel As Integer)

    Dim i As Integer

    For i = Forms.count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
    
    HF_Uninit
End Sub


Private Sub Form_Resize()
    On Error Resume Next
    If Me.Width < 3000 Then Me.Width = 3000
    SizeControls 0
End Sub

Sub SizeControls(X As Single)
    On Error Resume Next
    
    If X < 1500 Then X = 1500
    If X > (Me.Width - 1500) Then X = Me.Width - 1500
    lvListView.Left = 10
    lvListView.Width = Me.Width - 200

    lvListView.Top = 0
    
    If sbStatusBar.Visible Then
        lvListView.Height = Me.ScaleHeight - sbStatusBar.Height
    Else
        lvListView.Height = Me.ScaleHeight
    End If
    
End Sub

Private Sub lvListView_ItemClick(ByVal Item As MSComctlLib.listItem)
    Set mListItem = Item
End Sub

Private Sub mnuAddItem_Click()
    If gConnectionHandle = -1 Then Exit Sub
    If gGroupHandle = -1 Then Exit Sub

    dlgAddItem.Show vbModal, Me
    If dlgAddItem.mbReturn = False Then Exit Sub
    
    Dim br As Boolean
    Dim itemHandle As Long
    Dim buf(100) As Byte
    StringToByte dlgAddItem.mstrName, buf
    itemHandle = HF_AddItem(gConnectionHandle, gGroupHandle, buf(0))
    If itemHandle = -1 Then
        MsgBox "添加标签失败!"
        Exit Sub
    End If
    
    Dim strKey As String
    strKey = "k" & Str(itemHandle)
    g_ItemCol.Add dlgAddItem.mstrName, itemHandle, strKey
    
    
    lvListView.ListItems.Add 1, strKey, dlgAddItem.mstrName, 1, 1
End Sub

Private Sub mnuConnect_Click()
    If gConnectionHandle <> -1 Then
        MsgBox "Disconnect first!"
        Exit Sub
    End If

    ServerDlg.Show vbModal, Me
    If ServerDlg.mbReturn = False Then Exit Sub
    If Len(ServerDlg.mstrServerName) < 1 Then Exit Sub
    
    StringToByte ServerDlg.mstrMachineName, mMachineName
    StringToByte ServerDlg.mstrServerName, mServerName
    
    gConnectionHandle = HF_Connect(mMachineName(0), mServerName(0), ServerDlg.mbVer2)
    If gConnectionHandle = -1 Then
        MsgBox "连接失败!"
        Exit Sub
    End If
    
    
    'add opc group
    Dim strName As String
    Dim buf(100) As Byte
    strName = "Group1"
    StringToByte strName, buf
    
    Dim bActive As Boolean
    bActive = True
    
    Dim Rate, TimeBias, LCID As Long
    Rate = 1000
    TimeBias = 0
    LCID = 0
    
    Dim DeadBand As Single
    DeadBand = 0
    
    gGroupHandle = HF_AddGroup(gConnectionHandle, buf(0), bActive, Rate, TimeBias, DeadBand, LCID)
    If gGroupHandle = -1 Then
        MsgBox "添加组失败!"
        Disconnect
        Exit Sub
    End If
    
    mbReturn = HF_SetShutDownProc(gConnectionHandle, AddressOf ServerShutdownProc)
    mbReturn = HF_SetDataChangeProc(gConnectionHandle, AddressOf ServerDataChangeProc, 0)
    
    mnuConnect.Enabled = False
    mnuDisconnect.Enabled = True
    mnuAddItem.Enabled = True
    mnuRemoveItem.Enabled = True
    mnuReadItem.Enabled = True
    mnuWriteItem.Enabled = True
    
    Timer1.Enabled = True
End Sub

Private Sub mnuDisconnect_Click()
    Disconnect
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub
Private Sub mnuReadItem_Click()
    If mListItem Is Nothing Then Exit Sub
    
    Dim sKey As String
    Dim pItem As CItem
    
    sKey = mListItem.Key
    Set pItem = g_ItemCol(sKey)
    Dim Var As Variant
    Dim Ft As FILETIME
    Dim Quality As Long
    mbReturn = HF_ReadItem(gConnectionHandle, gGroupHandle, pItem.itemHandle, Var, Ft, Quality)
    If mbReturn = False Then
        MsgBox "读标签失败!"
    End If
    pItem.ItemValue = Var
    pItem.ItemTimeStamp = Win32FileTimeToVB(Ft)
    pItem.ItemQuality = Quality
End Sub

Private Sub mnuRemoveItem_Click()
    If mListItem Is Nothing Then Exit Sub
    
    Dim sKey As String
    
    sKey = mListItem.Key
    lvListView.ListItems.Remove mListItem.index
    g_ItemCol.Remove sKey
    
    Set mListItem = Nothing
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
    SizeControls 0
End Sub


Private Sub mnuWriteItem_Click()
    If mListItem Is Nothing Then Exit Sub
    
    Dim sKey As String
    Dim pItem As CItem
    
    sKey = mListItem.Key
    Set pItem = g_ItemCol(sKey)
    
    dlgWriteItem.Show vbModal, Me
    If dlgWriteItem.mbReturn = False Then Exit Sub
    
    Dim sValue As String
    sValue = dlgWriteItem.msValue
    If sValue = "" Then Exit Sub
    Debug.Print sValue
    
    Dim Var As Variant
    
    On Error GoTo Err
    
    Select Case VarType(pItem.ItemValue)
        Case vbBoolean
            Var = CBool(sValue)
        Case vbInteger
            Var = CInt(sValue)
        Case vbLong
            Var = CLng(sValue)
        Case vbSingle
            Var = CSng(sValue)
        Case vbString
            Var = CStr(sValue)
        Case Else
            GoTo Err
    End Select
    
    mbReturn = HF_WriteItem(gConnectionHandle, gGroupHandle, pItem.itemHandle, Var, 0)
    If mbReturn = False Then
        MsgBox "写标签失败!"
    End If
    
Err:
    Exit Sub
End Sub
Private Sub Timer1_Timer()
    Dim sName, sTmp As String
    Dim pItem As CItem
    
    Dim listItem As listItem
    
    On Error Resume Next
    For Each listItem In lvListView.ListItems
        sName = listItem.Key
        Set pItem = g_ItemCol(sName)
        FormatDataType pItem.ItemValue, sTmp
        listItem.SubItems(1) = sTmp
        listItem.SubItems(2) = CStr(pItem.ItemValue)
        listItem.SubItems(3) = CStr(pItem.ItemTimeStamp)
        FormatOpcQuality pItem.ItemQuality, sTmp
        listItem.SubItems(4) = sTmp
        
    Next
End Sub