mdlmain.bas

基于化工行业造气岗位的自动化监控系统

    If i >= 1000 Then
       FormatV = Format(Value, "0000")
    ElseIf i >= 100 Then
      FormatV = Format(Value, "000.0")
    ElseIf i >= 10 Then
       FormatV = Format(Value, "00.00")
    ElseIf i >= 1 Then
       FormatV = Format(Value, "0.00")
    ElseIf i >= 0 Then
       FormatV = Format(Value, "0.000")
    End If
End Function

'公共函数申明
'函数名：LinkAndSendMessage
'参  数：String msg
'返回值：Long 0-发送失败  1-发送成功
'描  述：采用冷连接与安装在本机的DDE服务器建立连接并发送格式为字符串的数据
Public Function LinkAndSendMessage(ByVal msg As String) As Long
    On Error GoTo HandleErr
    Dim i As Long
    With frmMain.txtSend
        .LinkMode = 0
        .LinkTopic = "DDEserver|DDE_Server"
        .LinkMode = 2
        .LinkExecute msg
        i = .LinkTimeout
        .LinkTimeout = 1
        .LinkMode = 0
        .LinkTimeout = i
    End With
    LinkAndSendMessage = 1
    Exit Function
HandleErr:
    Err.Clear
    frmMain.txtSend.LinkTimeout = 1
    frmMain.txtSend.LinkMode = 0
    frmMain.txtSend.LinkTimeout = i
    LinkAndSendMessage = 0
End Function
'函数名：LinkAndSendMessage_FJ
'参  数：String msg         发送字符串
'        COILRD             阀检服务程序名
'        CSYFFJ             话题名
'返回值：Nothing
'描  述：处理DDE发送
Public Function LinkAndSendMessage_FJ(ByVal msg As String)
    On Error GoTo errhandle
    Dim T   As Long
    With frmMain
        .txtValve.LinkMode = 0
        .txtValve.LinkTopic = "COILRD|CSYFFJ"
        .txtValve.LinkMode = 2
        .txtValve.LinkExecute msg
        T = .txtValve.LinkTimeout
        .txtValve.LinkTimeout = 1
        .txtValve.LinkMode = 0
        .txtValve.LinkTimeout = T
    End With
   Exit Function
errhandle:
     Err.Clear
End Function
'函数名：ReadInIFiles
'参  数：String Mainkey     主键字符
'        String Subkey      子键字符
'        String DefaultKey  默认值
'        String FileName    文件路径
'返回值：String
'描  述：从信息配置文件中读数据
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
    Const Falseread = "信息文件不存在或被破坏!"
    ReadBack = String(150, 0)
    Success = GetPrivateProfileString(Mainkey, Subkey, DefaultKey, ReadBack, 150, FileName)
    ReadInIFiles = Left(ReadBack, Success)
    If Success = 0 Then
       MsgBox Falseread, vbCritical, ErrorTitle
       ReadInIFiles = DefaultKey
    End If
End Function
Public Function GetIPAdd()
   Dim WSAD As WSAData
   Dim iReturn As Integer
   Dim sLowByte As String, sHighByte As String, sMsg As String
   Dim hostent_addr As Long
   Dim host As HOSTENT
   Dim hostip_addr As Long
   Dim temp_ip_address() As Byte
   Dim i As Integer
   Dim ip_address As String
   iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
   
   hostent_addr = gethostbyname(frmMain.txtSend.Text)
   RtlMoveMemory host, hostent_addr, LenB(host)
   RtlMoveMemory hostip_addr, host.hAddrList, 4
   
   ReDim temp_ip_address(1 To host.hLength)
   RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
   
   For i = 1 To host.hLength
      ip_address = ip_address & temp_ip_address(i) & "."
   Next
   ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
   If ip_address = "127.0.0.1" Then
      HostCount = False
   Else
      HostCount = True
   End If
End Function
Public Function SendMsg(ByVal strmsg As String)
    On Error GoTo errhandle
    Dim i As Long
    If IsServer Then
        For i = 1 To nClientWinsocks
            If frmMain.wskServer_Client(i).State = 7 Then
                frmMain.wskServer_Client(i).SendData strmsg
            End If
        Next i
    Else
        If frmMain.wskServer_Client(0).State = 7 Then
            frmMain.wskServer_Client(0).SendData strmsg
        End If
    End If
    Exit Function
errhandle:

'    ConnectState = False
    frmMain.wskServer_Client(i).Close
    Err.Clear
End Function

Public Function BroadMsg(ByVal strmsg As String)
On Error Resume Next
    frmMain.wskSend.RemoteHost = Trim("192.168.0.255")
    frmMain.wskSend.RemotePort = SendPort
    frmMain.wskSend.SendData strmsg
End Function
Public Function PostMsg(ByVal strmsg As String)
    Dim i As Long
    On Error Resume Next
    For i = 0 To nWinsocks
        If frmMain.wskRemote(i).State = 7 Then
            TimeDelay 10
            frmMain.wskRemote(i).SendData strmsg
        End If
    Next
End Function

Public Sub dbAutoManage() '数据库维护
'    Dim myRecordset As Recordset
'    On Error GoTo eLog
'    Dim i%
'    For i = 0 To db.TableDefs.Count - 1
'        If db.TableDefs(i).RecordCount > 5000 Then '
'            Set myRecordset = db.OpenRecordset(db.TableDefs(i).Name)
'            While myRecordset.RecordCount > 5000
'                myRecordset.MoveFirst
'                myRecordset.Delete
'            Wend
'            myRecordset.MoveLast
'            myRecordset.Close
'            Set myRecordset = Nothing
'        End If
'    Next
    Exit Sub
eLog:
    Err.Clear
End Sub
Public Function Exit_DB()
Dim i As Long, j As Long
    Dim strSend As String
    j = Val(ReadInIFiles("Flux", "Number", "0", iniPaths + "system.ini"))
    For i = 0 To j - 1
        WritePrivateProfileString "Flux", CStr(i), CStr(Flux(i)), iniPaths + "system.ini"
    Next
    If frmMain.cmdFj(0).Caption = "阀检关闭" Then Call LinkAndSendMessage_FJ("EXIT")
    For i = 0 To nClientWinsocks
        frmMain.wskServer_Client(i).Close
    Next
    For i = 0 To nWinsocks
      frmMain.wskRemote(i).Close
    Next
    If blnLock = True Then
        WritePrivateProfileString "Parameter", "LOCK", "1", iniPaths + "system.ini"
    Else
        WritePrivateProfileString "Parameter", "LOCK", "0", iniPaths + "system.ini"
    End If
    WritePrivateProfileString "Host", "UserID", CStr(UserID), iniPaths + "system.ini"
    If frmMain.MSComm5510.PortOpen = True Then
        frmMain.MSComm5510.InBufferCount = 0
        frmMain.MSComm5510.RThreshold = 0
        frmMain.MSComm5510.PortOpen = False
    End If
    RW_Tran.Exitdll
    Set RW_Tran = Nothing
    Set frmMain = Nothing
    End
End Function
Sub TimeDelay(DT As Long)
Dim T As Long
T = GetTickCount()
Do
   Sleep (10)
  DoEvents
Loop Until GetTickCount - T >= DT
End Sub

Public Function CheckRange(ByRef Value As Variant, ByVal Max As Variant, ByVal Min As Variant) As Variant
   On Error GoTo L
   If Value > Max Then
      Value = Max
   ElseIf Value < Min Then
      Value = Min
   End If
   CheckRange = Value
   Exit Function
L:
   Debug.Print Err.Description
   Err.Clear
End Function

Public Sub ParseStringToNumber(StringToParse As String, Single_Array() As Single, Optional Delimiter As String = "/")
    'StringToParse  要求分解的字符串
    'Single_Array() 分解后存放数据的数组
    'Delimiter      分隔符
    Dim L As Long
    Dim lngStartPos As Long
    Dim lngNextPos  As Long
    Dim strTemp     As String
    On Error Resume Next
    '初始化起始位置
    lngStartPos = 1
    Do
        '搜索指定的分隔符
        ReDim Preserve Single_Array(L)
        lngNextPos = InStr(lngStartPos, StringToParse, Delimiter)
        If lngNextPos = 0 Then
            ' For when we get to the end of the file
            strTemp = Val(Mid$(StringToParse, lngStartPos, Len(StringToParse) - lngNextPos + 1))
        Else
            strTemp = Val(Mid$(StringToParse, lngStartPos, lngNextPos - lngStartPos + 1))
        End If
        '对存放数据的变量赋值
        Single_Array(L) = Val(strTemp)
        
        lngStartPos = lngNextPos + 1
        L = L + 1
    Loop Until lngNextPos = 0
End Sub

Public Sub ParseStringToStr(StringToParse As String, ByRef Str_Array() As String, Optional Delimiter As String = "@")
    'StringToParse  要求分解的字符串
    'Str_Array()    分解后存放字符的数组
    'Delimiter      分隔符
    Dim L As Long
    Dim lngStartPos As Long
    Dim lngNextPos  As Long
    Dim strTemp     As String
    On Error Resume Next
    '初始化起始位置
    lngStartPos = 1
    Do
        ReDim Preserve Str_Array(L)
        lngNextPos = InStr(lngStartPos, StringToParse, Delimiter)
        If lngNextPos = 0 Then
            strTemp = Mid$(StringToParse, lngStartPos, Len(StringToParse) - lngNextPos + 1)
        Else
            strTemp = Mid$(StringToParse, lngStartPos, lngNextPos - lngStartPos)
        End If
        Str_Array(L) = strTemp
        lngStartPos = lngNextPos + 1
        L = L + 1
    Loop Until lngNextPos = 0
End Sub
'私有函数申明
'函数名：OpenSignalMap
'参  数：String FileName
'返回值：Long 0-打开失败  1-打开成功
'描  述：打开信号点配置文件并导出配置表中的数据保存到类型为采集点信号类型的数组变量
Private Function OpenSignalMap(ByVal FileName As String) As Long
    Dim FileHandle As Long
    Dim RecordNums As Long
    Dim i As Long
    On Error GoTo errhandle
    If FileName <> "" Then
        FileHandle = FreeFile
        Open FileName For Random As #FileHandle Len = Len(Signal(0))
        RecordNums = LOF(FileHandle) / Len(Signal(0))
        ReDim Preserve Signal(0 To RecordNums - 1)
        For i = 0 To RecordNums - 1 Step 1
            Get #FileHandle, i + 1, Signal(i)
'            Debug.Print Signal(i).Name & "=" & MotherBoard(Signal(i).Board).Port_Dip & "-" & Signal(i).Slot & "-" & Signal(i).Channel
            If Signal(i).Pid Then
                PID_Number = PID_Number + 1
                ReDim Preserve Pid(PID_Number - 1)
                Pid(PID_Number - 1).inID = i
                Pid(PID_Number - 1).outID = Signal(i).Pid_ID
                Pid(PID_Number - 1).Address = Format(MotherBoard(Signal(i).Board).Port_Dip, "00")
                Pid(PID_Number - 1).Channel = Signal(i).Channel
                
            End If
        Next i
        Close #FileHandle
        If RecordNums = 0 Then
            OpenSignalMap = 0
        Else
            OpenSignalMap = 1
        End If
    Else
        OpenSignalMap = 0
    End If
    Exit Function
errhandle:
    Err.Clear
    OpenSignalMap = 0
End Function

Public Function OpenValveMap(ByVal FileName As String) As Long
    Dim FileHandle As Long
    Dim RecordNums As Long
    Dim i As Long
    On Error GoTo errhandle
    If FileName <> "" Then
        FileHandle = FreeFile
        Open FileName For Random As #FileHandle Len = Len(DSignal(0))
        RecordNums = LOF(FileHandle) / Len(DSignal(0))
        ReDim Preserve DSignal(0 To RecordNums - 1)
        For i = 0 To RecordNums - 1 Step 1
            Get #FileHandle, i + 1, DSignal(i)
'            Debug.Print i & "+" & DSignal(i).Name & "+" & DSignal(i).Address & "+" & DSignal(i).Channel & "+" & DSignal(i).Value
        Next i
        Close #FileHandle
        If RecordNums = 0 Then
            OpenValveMap = 0
        Else
            OpenValveMap = 1
        End If
    Else
        OpenValveMap = 0
    End If
    Exit Function
errhandle:
    Err.Clear
    OpenValveMap = 0
End Function

Private Function OpenMotherBoardMap(FileName As String) As Long
    Dim FileHandle As Long