mdlmain.bas

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

Public OPCSEnabled As Boolean
Public OPCCEnabled As Boolean
Public DDEdataIn() As Label                     'DDE输入数据
Public DDEdataOut() As Label                    'DDE输出数据
Public DDEConnectFlag As Boolean                'DDE连接标志
Public SYSdataIn() As Integer
Public SYSdataOut() As Integer
Public Flux_Time As Single
Public connectCount() As Integer
Public ModuleOpen As Boolean
Public ModuleConnectState() As Boolean
Public MotherBoard() As Board
Public Signal() As SignalInfo       '采集点信息
Public CalcStr() As String          '非线性算法公式
Public LED_ID As Integer
Public Warning_ID As Integer
Public lngLEDRow As Integer
Public RecNumber As Integer
Public ControlLink As Control
Public IsServer As Boolean
Public isRead As Boolean
Public IsTran As Boolean
Public Is4000 As Boolean
Public Is5000 As Boolean
Public Is6080 As Boolean
Public Flux() As Single            '蒸汽流量累计值
Public QIGUIhight As Long
Public ZQYLclac As Single
Public LTZSclac As Single
Public SXYLclac As Single
Public XXYLclac As Single

'入口函数
 Sub Main()
    Dim i As Long, j As Long, k As Long, H As Long
    Dim hostname As String           '主机名称
'    On Error Resume Next
    iniPaths = App.path + "\ini\"
    If App.PrevInstance Then
         MsgBox ("程序已经运行，不能再次装载。"), vbExclamation
         End
    End If
    Call AutoReg
    '打开采集点配置信息文件
    ReDim Preserve MotherBoard(0)
    i = OpenMotherBoardMap(App.path + "\MDB\Moudle.map")
    If i = 0 Then
        i = OpenMotherBoardMap(App.path + "\bak\Moudle.map")
    End If
    If i = 0 Then MsgBox "信息文件破坏，无法打开!", vbOKOnly, ErrorTitle: End
    ReDim ModuleConnectState(UBound(MotherBoard))
    ReDim connectCount(UBound(MotherBoard))
    ReDim Signal(0)
    i = OpenSignalMap(App.path + "\MDB\Point.map")
    If i = 0 Then
        i = OpenSignalMap(App.path + "\bak\Point.map")
    End If
    If i = 0 Then MsgBox "信息文件破坏，无法打开!", vbOKOnly, ErrorTitle: End
    
    '创建数据库目录
    If SetCurrentDirectory("D:\Program Files") = 0 Then
        MkDir "D:\Program Files"
    End If
    datPaths = "D:\Program Files"
    IsAcess = False
    Dim NewDataBase As String, NewUid As String, NewPwd As String, Tempstr As String
    NewDataBase = ReadInIFiles("DB", "Database", "Factory", iniPaths + "system.ini")
    NewUid = ReadInIFiles("DB", "User", "sa", iniPaths + "system.ini")
    On Error GoTo NewSQL
    Conn.OPEN "PROVIDER=MSDASQL;driver={SQL Server};server=(local);uid=" & NewUid & ";pwd=;database=" & NewDataBase & ";"
'    Read_Conn.OPEN "PROVIDER=MSDASQL;driver={SQL Server};server=(local);uid=" & NewUid & ";pwd=;database=" & NewDataBase & ";"
    Write_Conn.OPEN "PROVIDER=MSDASQL;driver={SQL Server};server=(local);uid=" & NewUid & ";pwd=;database=" & NewDataBase & ";"
    GoTo Continue
NewSQL:
    If SetCurrentDirectory(datPaths & "\DataBase") = 0 Then
       MkDir datPaths & "\Database"
    End If
       On Error GoTo OpenAccess
       If MsgBox("数据库已损坏，重建数据库吗？", vbQuestion + vbYesNo, ErrorTitle) = vbYes Then
            
            Dim fso As New FileSystemObject
            Set fso = CreateObject("Scripting.FileSystemObject")
            TimeDelay 100
            fso.CopyFile App.path & "\mdb\" & NewDataBase & ".mdf", datPaths & "\DataBase\"
            SetAttr (datPaths & "\DataBase\" & NewDataBase & ".mdf"), vbNormal
            SetAttr (datPaths & "\DataBase\" & NewDataBase & ".mdf"), vbArchive
            fso.CopyFile App.path & "\mdb\" & NewDataBase & ".ldf", datPaths & "\DataBase\"
            SetAttr (datPaths & "\DataBase\" & NewDataBase & ".ldf"), vbNormal
            SetAttr (datPaths & "\DataBase\" & NewDataBase & ".ldf"), vbArchive
            Tempstr = "sp_attach_db @dbname = N'" & NewDataBase & " ',@filename1 = N'" & datPaths & "\Database\" & NewDataBase & ".mdf',@filename2 = N'" & datPaths & "\Database\" & NewDataBase & ".ldf'"
            Conn.OPEN "driver={sql server};server=(local);database=master;persist security info=false; userid=" & NewUid & ";password=" & NewPwd
            Conn.Execute Tempstr
            TimeDelay 5000
            MsgBox "数据库加载成功，请重新加载程序或是注销系统！"
            End
       Else
            GoTo OpenAccess
       End If
    GoTo Continue
OpenAccess:
    IsAcess = True
    On Error GoTo ErrHandle
    Conn.CursorLocation = adUseClient
    Conn.OPEN "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\mdb\DCS.mdb;"
        
'    Read_Conn.CursorLocation = adUseClient
'    Read_Conn.OPEN "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\mdb\DCS.mdb;"
    Write_Conn.CursorLocation = adUseClient
    Write_Conn.OPEN "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\mdb\DCS.mdb;"
Continue:
    On Error Resume Next
    Set Cmd.ActiveConnection = Conn
'    Set Read_Cmd.ActiveConnection = Read_Conn
    Set Write_Cmd.ActiveConnection = Write_Conn
    
    '读取机器名判断Server/Client，控制计算数据
    DCSName = ReadInIFiles("DCS", "Name", "化肥厂", iniPaths + "system.ini")
    DCSVersion = ReadInIFiles("DCS", "Version", "2.0.1", iniPaths + "system.ini")
    hostname = UCase(ReadInIFiles("Host", "Name", "Server", iniPaths + "system.ini"))
    UserID = ReadInIFiles("Host", "UserID", "1", iniPaths + "system.ini")
    Gather_Time = Int(Val(ReadInIFiles("ADAM5510", "Gathertime", "250", iniPaths + "system.ini")))
    StoveStart = Val(ReadInIFiles("Window", "StoveStart", "1", iniPaths + "system.ini"))
    StoveNumber = Val(ReadInIFiles("Window", "StoveNumber", "12", iniPaths + "system.ini"))
    WindowNumber = Val(ReadInIFiles("Window", "WindowNumber", "2", iniPaths + "system.ini"))
    IsTran = ReadInIFiles("TRAN", "ISTRAN", "false", iniPaths + "system.ini")
    QIGUIhight = Val(ReadInIFiles("Window", "QIGUIhight", "10", iniPaths + "system.ini"))
    
    ReDim Preserve Number(1 To WindowNumber)
    For i = 1 To WindowNumber
        Number(i) = Val(ReadInIFiles("Window", "Number" & i, "6", iniPaths + "system.ini"))
    Next
    For i = 0 To StoveNumber - 1
        ReDim Preserve Stove(i)
        ReDim Preserve safety_Stop(i)
        With Stove(i)
             .ip = Replace(ReadInIFiles("Stove" & i + 1, "IP", "0", iniPaths + "Stove.ini"), Chr(0), "")
             .CF_Control = Val(ReadInIFiles("Stove" & i + 1, "CF", "0", iniPaths + "Stove.ini"))
             .SC_Control = Val(ReadInIFiles("Stove" & i + 1, "SC", "0", iniPaths + "Stove.ini"))
             .SXWD_Control = Val(ReadInIFiles("Stove" & i + 1, "SXWD", "0", iniPaths + "Stove.ini"))
             .XXWD_Control = Val(ReadInIFiles("Stove" & i + 1, "XXWD", "0", iniPaths + "Stove.ini"))
             .Queue_Control = Val(ReadInIFiles("Stove" & i + 1, "Queue", "0", iniPaths + "Stove.ini"))
             .CycleTime = Val(ReadInIFiles("Stove" & i + 1, "CycleTime", "0", iniPaths + "Stove.ini"))
             .SJN_Control = Val(ReadInIFiles("Stove" & i + 1, "SJN", "0", iniPaths + "Stove.ini"))
             .CycleLJ = Val(ReadInIFiles("Stove" & i + 1, "CycleLJ", "0", iniPaths + "Stove.ini"))
             .SetSpeed = Val(ReadInIFiles("Stove" & i + 1, "SetSpeed", "0", iniPaths + "Stove.ini"))
             .Name = Format(i + StoveStart, "00")
         End With
    Next
    ReDim StoveValveInfr(0 To StoveNumber - 1)
    For i = 0 To StoveNumber - 1
      StoveValveInfr(i).SpeedAuto = ReadInIFiles("Stove" & i + 1, "SpeedAuto", "0", iniPaths + "system.ini")
      StoveValveInfr(i).OnOff = "000000000000"
      StoveValveInfr(i).SpeedSetV = Val(ReadInIFiles("Stove" & i + 1, "Speed", "200", iniPaths + "system.ini"))
      StoveValveInfr(i).AddCoalTime = 2.5
    Next
    frmSplash.Show
    If hostname = "SERVER" Then
        IsServer = True
    Else
        IsServer = False
    End If
    
    
    
    If StoveNumber > UBound(Stove) + 1 Then
        ReDim Preserve Stove(StoveNumber)
    Else
        StoveNumber = UBound(Stove) + 1
    End If
    ReDim blnRHS(StoveNumber)
    ReDim ParaEdit(StoveNumber)
    paraNumber = Val(ReadInIFiles("Parameter", "ParaNumber", "7", iniPaths + "system.ini"))  '工艺参数数量
    lngLEDRow = Val(ReadInIFiles("Window", "LEDROW", 1, iniPaths + "system.ini"))       '公共数据显示列数
    '生成历史数据保存文件夹并记录系统启动时间
    If SetCurrentDirectory(datPaths & "\history") = 0 Then  '建立子目录
        MkDir datPaths & "\history"
    End If
    If SetCurrentDirectory(datPaths & "\history\Alarm") = 0 Then
        MkDir datPaths & "\history\Alarm"
    End If
    If SetCurrentDirectory(datPaths & "\history\Work") = 0 Then
        MkDir datPaths & "\history\Work"
    End If
    If SetCurrentDirectory(datPaths & "\history\qlhistory") = 0 Then
       MkDir datPaths & "\history\qlhistory"
    End If
    For i = 1 To StoveNumber
         If i < 10 Then
             If SetCurrentDirectory(datPaths & "\history\qlhistory\00" & i) = 0 Then
                MkDir datPaths & "\history\qlhistory\00" & i
             End If
         Else
             If SetCurrentDirectory(datPaths & "\history\qlhistory\0" & i) = 0 Then
                MkDir datPaths & "\history\qlhistory\0" & i
             End If
         End If
     Next i
    If SetCurrentDirectory(datPaths & "\history\Hhistory") = 0 Then
       MkDir datPaths & "\history\Hhistory"
    End If
    If SetCurrentDirectory(datPaths & "\history\WDhistory") = 0 Then
       MkDir datPaths & "\history\WDhistory"
    End If
    If SetCurrentDirectory(datPaths & "\history\YLhistory") = 0 Then
       MkDir datPaths & "\history\YLhistory"
    End If
    If SetCurrentDirectory(datPaths & "\history\LLhistory") = 0 Then
       MkDir datPaths & "\history\LLhistory"
    End If
    If SetCurrentDirectory(datPaths & "\history\YWhistory") = 0 Then
       MkDir datPaths & "\history\YWhistory"
    End If
    If SetCurrentDirectory(App.path & "\Logevent") = 0 Then
       MkDir App.path & "\Logevent"
    End If
    If SetCurrentDirectory(App.path & "\dat") = 0 Then
        MkDir App.path & "\dat"
        Dim Fs As Object, A As Object
        Set Fs = CreateObject("Scripting.FileSystemObject")
        Set A = Fs.CreateTextFile(App.path & "\dat\Start.txt", True) '记录系统何时启动
        A.WriteLine Format(Date, "yyyy-mm-dd") & "#" & Format(Time, "hh:mm:ss") & "  SYSTEM Staring..."
        A.Close
        Set A = Nothing
        Set Fs = Nothing
    Else
        Open App.path & "\dat\Start.txt" For Append As #1
        Print #1, Format(Date, "yyyy-mm-dd") & "#" & Format(Time, "hh:mm:ss") & "  SYSTEM Staring..."      '记录系统何时启动
        Close #1
    End If
    Call INI_Curve
    Call INI_Catenation
    
BL:
    frmMain.Show
    Exit Sub
ErrHandle:
    Err.Clear
    End
End Sub
Public Function AutoReg()
Dim Ocx() As Byte, Counter As Long
Dim OldName
Dim Result As Double
Dim Fs As Object
Const OCXSIZE1 = 139264
Const OCXSIZE2 = 40960
Const OCXSIZE3 = 217088
Const OCXSIZE4 = 217088
Const OCXSIZE5 = 73780
Const OCXSIZE6 = 126976

    Set Fs = CreateObject("Scripting.FileSystemObject")
    '101,XPCURVE.dll,(139264)
    OldName = Fs.GetSpecialFolder(1) & "\XPCURVE.DLL"
    If Dir(OldName) = "" Then
        Ocx = LoadResData(101, "CUSTOM")
        Open OldName For Binary As #1
        For Counter = 0 To OCXSIZE1 - 1
          Put #1, , Ocx(Counter)
        Next Counter
        Close #1
        Result = Shell("RegSvr32 /s " + "XPCURVE.DLL")
        If Result = 0 Then
            Unload frmMessage
            frmMessage.lblMsg = OldName & "注册失败！"
            frmMessage.Show
        End If
    Else
        If FileLen(OldName) <> OCXSIZE1 Then
            Name (OldName) As (OldName & "." & Format(Date, "yyyymmdd") & Second(Time))
            Ocx = LoadResData(101, "CUSTOM")
            Open OldName For Binary As #1
            For Counter = 0 To OCXSIZE1 - 1
              Put #1, , Ocx(Counter)
            Next Counter
            Close #1
            Result = Shell("RegSvr32 /s " + "XPCURVE.DLL")
        End If
    End If
    '102,Prgress.ocx,(40960)
    OldName = Fs.GetSpecialFolder(1) & "\Prgress.ocx"
    If Dir(OldName) = "" Then
        Ocx = LoadResData(102, "CUSTOM")
        Open OldName For Binary As #1
        For Counter = 0 To OCXSIZE2 - 1
          Put #1, , Ocx(Counter)
        Next Counter
        Close #1
        Result = Shell("RegSvr32 /s " + "Prgress.ocx")
        If Result = 0 Then
            Unload frmMessage
            frmMessage.lblMsg = OldName & "注册失败！"
            frmMessage.Show
        End If
    Else
        If FileLen(OldName) <> OCXSIZE2 Then
            Name (OldName) As (OldName & "." & Format(Date, "yyyymmdd") & Second(Time))
            Ocx = LoadResData(102, "CUSTOM")
            Open OldName For Binary As #1
            For Counter = 0 To OCXSIZE2 - 1
              Put #1, , Ocx(Counter)
            Next Counter
            Close #1
            Result = Shell("RegSvr32 /s " + "Prgress.ocx")
        End If
    End If
    '103,curtPrinter.ocx,(217088)
    OldName = Fs.GetSpecialFolder(1) & "\curtPrinter.ocx"
    If Dir(OldName) = "" Then
        Ocx = LoadResData(103, "CUSTOM")
        Open OldName For Binary As #1
        For Counter = 0 To OCXSIZE3 - 1
          Put #1, , Ocx(Counter)
        Next Counter
        Close #1
        Result = Shell("RegSvr32 /s " + "curtPrinter.ocx")
        If Result = 0 Then
            Unload frmMessage
            frmMessage.lblMsg = OldName & "注册失败！"
            frmMessage.Show
        End If
    Else
        If FileLen(OldName) <> OCXSIZE3 Then
            Name (OldName) As (OldName & "." & Format(Date, "yyyymmdd") & Second(Time))
            Ocx = LoadResData(103, "CUSTOM")
            Open OldName For Binary As #1
            For Counter = 0 To OCXSIZE3 - 1
              Put #1, , Ocx(Counter)
            Next Counter
            Close #1
            Result = Shell("RegSvr32 /s " + "curtPrinter.ocx")
        End If
    End If
    '104,OptionCurve.ocx,(217088)
    OldName = Fs.GetSpecialFolder(1) & "\OptionCurve.ocx"
    If Dir(OldName) = "" Then
        Ocx = LoadResData(104, "CUSTOM")
        Open OldName For Binary As #1
        For Counter = 0 To OCXSIZE4 - 1
          Put #1, , Ocx(Counter)
        Next Counter
        Close #1
        Result = Shell("RegSvr32 /s " + "OptionCurve.ocx")
        If Result = 0 Then
            Unload frmMessage
            frmMessage.lblMsg = OldName & "注册失败！"
            frmMessage.Show
        End If