module1.vb

OPC-Client sdk for vb/vb.net/c#

Option Strict Off
Option Explicit On
Imports VB = Microsoft.VisualBasic
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
    'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"”
    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
    'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"”
    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
    'UPGRADE_WARNING: 结构 FILETIME 可能要求封送处理属性作为此 Declare 语句中的参数传递。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"”
    Declare Function FileTimeToLocalFileTime Lib "kernel32" (ByRef lpFileTime As FILETIME, ByRef lpLocalFileTime As FILETIME) As Integer
    'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"”
    Declare Function LocalFileTimeToFileTime Lib "kernel32" (ByRef lpLocalFileTime As String, ByRef lpFileTime As String) As Integer
    'UPGRADE_ISSUE: 不支持将参数声明为“As Any”。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"”
    '  Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As String, ByRef hpvSource As String, ByVal cbCopy 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 Handle As Integer
        Dim Name As String
        Dim Value As Object
        Dim Quality As Short
        Dim Ft As FILETIME
        Dim Index As Integer
    End Structure

    Public ItemArr(1024) As OPCItem
    Public ItemIndex As Short
    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
        'Dim Falseread As String
        ReadBack = New String(Chr(0), 150)
        Success = GetPrivateProfileString(Mainkey, Subkey, DefaultKey, ReadBack, 150, FileName)
        ReadInIFiles = Left(ReadBack, Success)
        If Success = 0 Then
            ' Falseread = FileName & Chr(13) & Chr(10) & "[" & Mainkey & "]" & _
            ''                Chr(13) & Chr(10) & Subkey & Chr(13) & Chr(10) & "信息文件不存在或被破坏!"
            ' MsgBox Falseread, vbCritical, "错误"
            ReadInIFiles = DefaultKey
        End If
    End Function

    Public Function DoubleToFileTime(ByVal Value As Double) As FILETIME
        Dim ftdt As FILETIME
        'UPGRADE_WARNING: 未能解析对象 ftdt 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
        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())
        'UPGRADE_WARNING: 未能解析对象 DoubleToFileTime 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
        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 Finditem(ByRef ItemHandle As Integer) As Short
        Dim I As Short
        For I = 1 To ItemIndex
            If ItemArr(I).Handle = ItemHandle Then
                Finditem = ItemArr(I).Index
                Exit For
            End If
        Next
    End Function

    Public Function AddItemM(ByRef ItemName As String) As Short
        Dim h As Integer
        If ItemIndex > 1023 Then Exit Function
        'UPGRADE_WARNING: 未能解析对象 ServerHandle 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
        h = OPC_AddItem(ServerHandle, GroupHandle, ItemName)
        If h > 0 Then
            '        Debug.Print h
            ItemIndex = ItemIndex + 1
            ItemArr(ItemIndex).Handle = h
            ItemArr(ItemIndex).Name = ItemName
            ItemArr(ItemIndex).Index = ItemIndex
            AddItemM = ItemIndex
            frmMain.lstProcess.Items.Add("ItemArr(" & ItemIndex & ").Handle=" & h & ",Name=" & ItemName)
        End If
    End Function

    Public Function RemoveItem(ByRef Index As Integer) As Boolean
        If Index > 0 And Index < 1025 Then
            'UPGRADE_WARNING: 未能解析对象 ServerHandle 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
            If OPC_RemoveItem(ServerHandle, GroupHandle, ItemArr(Index).Handle) Then
                ItemArr(Index).Handle = 0
                RemoveItem = True
            End If
        End If
    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
        'UPGRADE_WARNING: 集合 frmMain.sbStatusBar.Panels 的下限已由 1 更改为 0。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="A3B628A0-A810-4AE2-BFA2-9E7A29EB9AD0"”
        frmMain.sbStatusBar.Items.Item(1).Text = VB.Timer() & " ItemHandle=" & ItemHandle
        Index = Finditem(ItemHandle)

        If Index > 0 Then
            'UPGRADE_WARNING: 未能解析对象 ItemArr().Ft 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
            ItemArr(Index).Ft = DoubleToFileTime(Ft)
            'UPGRADE_WARNING: 未能解析对象 Value 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
            ItemArr(Index).Value = Value
            ItemArr(Index).Quality = Quality
            Debug.Print(Index)
            frmMain.RefreshItem((Index))
        Else
            'UPGRADE_WARNING: 未能解析对象 Value 的默认属性。 单击以获得更多信息:“ms-help://MS.VSCC.v80/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"”
            frmMain.lstProcess.Items.Add(ItemHandle & " " & Value)
        End If
    End Sub

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

    End Sub
    '  dim Host(20) As Byte,ip(20) As Byte<VBFixedString(301)>
    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