module1.vb

OPC CLIENT开发包

Option Strict Off
Option Explicit On

Imports System.Text
Imports System.Runtime.InteropServices

Module Module1

    Private Const rDayZeroBias As Double = 109205.0#
    Private Const rMillisecondPerDay As Double = 10000000.0# * 60.0# * 60.0# * 24.0# / 10000.0#
    <StructLayout(LayoutKind.Sequential)> _
    Public Structure FILETIME
        <MarshalAs(UnmanagedType.I4, SizeConst:=4)> _
        Dim dwLowDateTime As Integer
        <MarshalAs(UnmanagedType.I4, SizeConst:=4)> _
        Dim dwHighDateTime As Integer
    End Structure

    Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Integer
    Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
    Declare Function FileTimeToLocalFileTime Lib "kernel32" (ByRef lpFileTime As FILETIME, ByRef lpLocalFileTime As FILETIME) As Integer
    Declare Function LocalFileTimeToFileTime Lib "kernel32" (ByRef lpLocalFileTime As String, ByRef lpFileTime As String) As Integer
    Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As IntPtr, ByVal Source As IntPtr, ByVal Length As Integer)
    Public ServerHandle As Object
    Public GroupHandle As Integer
    Public GroupName As String

    Public Structure ServerItem
        Dim ServerName As String
        Dim ServerClassID As String
    End Structure

    Public ServerItems(99) As ServerItem

    Public Structure OPCItem
        Dim Name As String
        Dim Value As Object
        Dim Quality As Short
        Dim Ft As FILETIME
    End Structure

    Public ItemArr(1024) As OPCItem

    Public Function ReadInIFiles(ByRef Mainkey As String, ByRef Subkey As String, ByRef DefaultKey As String, ByRef FileName As String) As String
        Dim Success As Integer
        Dim ReadBack As String
        ReadBack = New String(New Char, 150)
        Success = GetPrivateProfileString(Mainkey, Subkey, DefaultKey, ReadBack, 150, FileName)
        ReadInIFiles = ReadBack.Substring(0, Success)
        If Success = 0 Then
            ReadInIFiles = DefaultKey
        End If
    End Function

    Public Function DoubleToFileTime(ByVal Value As Double) As FILETIME
        Dim ftdt As FILETIME
        Dim source As IntPtr, dest As IntPtr
        source = Marshal.AllocHGlobal(Marshal.SizeOf(Value))
        Marshal.StructureToPtr(Value, source, True)
        dest = Marshal.AllocHGlobal(Marshal.SizeOf(ftdt)) '或者别的方式获得的非托管内存地址
        CopyMemory(dest, source, Marshal.SizeOf(Value))
        ftdt = Marshal.PtrToStructure(dest, ftdt.GetType())
        DoubleToFileTime = ftdt
    End Function

    Public Function FileTimeToDate(ByRef hFileTime As FILETIME) As Date
        Dim ftl As Decimal '在VB6下用currency
        Dim tm As Long
        Dim Ft As FILETIME
        FileTimeToLocalFileTime(hFileTime, Ft)
        Dim source As IntPtr, dest As IntPtr
        source = Marshal.AllocHGlobal(Marshal.SizeOf(Ft))
        Marshal.StructureToPtr(Ft, source, True)
        dest = Marshal.AllocHGlobal(Marshal.SizeOf(tm)) '或者别的方式获得的非托管内存地址
        CopyMemory(dest, source, Marshal.SizeOf(Ft))
        tm = Marshal.PtrToStructure(dest, tm.GetType())
        ftl = tm
        ftl = ftl / 10000 '搞不清为什么要除10000,害我调几个小时
        FileTimeToDate = System.DateTime.FromOADate((ftl / rMillisecondPerDay) - rDayZeroBias)
    End Function

    Public Function AddItemM(ByRef ItemName As String) As Short
        Dim h As Integer
        h = OPC_AddItem(ServerHandle, GroupHandle, ItemName)
        If h > 0 Then
            ItemArr(h).Name = ItemName
            AddItemM = h
            frmMain.lstProcess.Items.Add("ItemArr(" & h & ").Handle=" & h & ",Name=" & ItemName)
        End If
    End Function

    Public Function RemoveItem(ByRef Index As Integer) As Boolean
        RemoveItem = (OPC_RemoveItem(ServerHandle, GroupHandle, Index) <> 0)
    End Function

    Sub ServerDataChangeProc(ByVal ServerHandle As Integer, ByVal GroupHandle As Integer, ByVal ItemHandle As Integer, ByVal Value As Object, ByVal Ft As Double, ByVal Quality As Short)
        On Error Resume Next
        Dim Index As Short
        frmMain.sbStatusBar.Items.Item(1).Text = DateTime.Now.ToString() & " ItemHandle=" & ItemHandle
        If ItemHandle > 0 Then
            ItemArr(ItemHandle).Ft = DoubleToFileTime(Ft)
            ItemArr(ItemHandle).Value = Value
            ItemArr(ItemHandle).Quality = Quality
            frmMain.RefreshItem(ItemHandle)
        Else
            frmMain.lstProcess.Items.Add(ItemHandle & " " & Value)
        End If
    End Sub
    Sub ServerDataChangeProcEx(ByVal ServerHandle As Integer, ByVal GroupHandle As Integer, ByRef ItemHandle As Object, ByRef Value As Object, ByRef Ft As Object, ByRef Quality As Object)
        Dim Index As Integer
        '   Program.mainWindow.sbStatusBar.Items[1].Text = " ItemHandle=" + ItemHandle.ToString();
        Dim tmp1() As Object
        tmp1 = ItemHandle
        Dim tmp2() As Object
        tmp2 = Value
        Dim tmp3() As Object
        tmp3 = Ft
        Dim tmp4() As Object
        tmp4 = Quality

        Dim i As Integer
        For i = 0 To tmp1.Length
            Index = tmp1(i)
            If (Index > 0) Then
                ItemArr(Index).Ft = DoubleToFileTime(tmp3(i))
                ItemArr(Index).Value = tmp2(i)
                ItemArr(Index).Quality = tmp4(i)
                frmMain.RefreshItem(Index)
            Else
                frmMain.lstProcess.Items.Add(ItemHandle & " " & Value)
            End If
        next
    End Sub

    Sub ServerShutdownProc(ByVal ServerHandle As Integer)
        frmMain.Disconnect()
    End Sub

    Sub AddLandHostIP(ByVal Host As StringBuilder, ByVal ip As StringBuilder)
        frmServerBrowser.cbHost.Items.Add(Host.ToString())
    End Sub
    Sub AddOPCname(ByVal Name As String, ByVal clsid As String)
        With frmServerBrowser
            .listServer.Items.Add(Name)
            ServerItems(.gServerID).ServerName = Name
            ServerItems(.gServerID).ServerClassID = clsid
            .gServerID = .gServerID + 1
        End With
    End Sub

    Sub AddProcess(ByVal ev As StringBuilder)
        frmMain.lstProcess.Items.Add(ev)
    End Sub
End Module