module1.bas

delphiopc

Attribute VB_Name = "Module1"
Option Explicit

Private Const rDayZeroBias As Double = 109205#
Private Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As Any, lpFileTime As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public ServerHandle, GroupHandle As Long
Public GroupName  As String

Public Type ServerItem
    ServerName As String
    ServerClassID As String
End Type

Public ServerItems(99) As ServerItem

Public Type OPCItem
    Handle As Long
    Name As String
    Value As Variant
    Quality As Integer
    Ft As FILETIME
    Index As Long
End Type

Public ItemArr(1024) As OPCItem
Public ItemIndex As Integer
Public Function ReadInIFiles(Mainkey As String, Subkey As String, DefaultKey As String, FileName As String) As String
    Dim Success As Long
    Dim ReadBack As String
    Dim Falseread As String
    ReadBack = String(150, 0)
    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
    CopyMemory ftdt, Value, Len(Value)
    DoubleToFileTime = ftdt
End Function

Public Function FileTimeToDate(hFileTime As FILETIME) As Date
    Dim ftl As Currency, Ft As FILETIME
    FileTimeToLocalFileTime hFileTime, Ft
    CopyMemory ftl, Ft, Len(Ft)
    FileTimeToDate = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)
End Function

Public Function Finditem(ItemHandle As Long) As Integer
    Dim I As Integer
    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(ItemName As String) As Integer
    Dim h As Long
    If ItemIndex > 1023 Then Exit Function
    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.AddItem "ItemArr(" & ItemIndex & ").Handle=" & h & ",Name=" & ItemName
    End If
End Function

Public Function RemoveItem(Index As Long) As Boolean
    If Index > 0 And Index < 1025 Then
        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 Long, ByVal GroupHandle As Long, ByVal ItemHandle As Long, ByVal Value As Variant, ByVal Ft As Double, ByVal Quality As Integer)
    On Error Resume Next
    Dim Index As Integer
    frmMain.sbStatusBar.Panels(1) = Timer & " ItemHandle=" & ItemHandle
    Index = Finditem(ItemHandle)
    
    If Index > 0 Then
        ItemArr(Index).Ft = DoubleToFileTime(Ft)
        ItemArr(Index).Value = Value
        ItemArr(Index).Quality = Quality
        Debug.Print Index
        frmMain.RefreshItem (Index)
    Else
        frmMain.lstProcess.AddItem ItemHandle & " " & Value
    End If
End Sub

Sub ServerShutdownProc(ByVal ServerHandle As Long)
    frmMain.Disconnect
End Sub
Sub AddLandHostIP(ByVal Host As String, ByVal ip As String)
   frmServerBrowser.cbHost.AddItem Host
End Sub
Sub AddOPCname(ByVal Name As String, ByVal clsid As String)
    With frmServerBrowser
        .listServer.AddItem Name
         ServerItems(.gServerID).ServerName = Name
         ServerItems(.gServerID).ServerClassID = clsid
         .gServerID = .gServerID + 1
    End With
End Sub

Sub AddProcess(ByVal ev As String)
   frmMain.lstProcess.AddItem ev
End Sub