mdlmain.bas

这是一个实际的工程中所用的源程序

Attribute VB_Name = "mdlMain"
Option Explicit
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
'    aa = SetTimer(Me.hwnd, 1, sleepTime(m_cbSleepTime.ListIndex), AddressOf TimerProc)
'    aa = KillTimer(Me.hwnd,  1)

Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Const App_Title As String = "皮带秤计量管理系统"  '程序管理系统名称
Public Const App_Help As String = "皮带秤计量管理系统.chm"
Public Const App_PATH_ROOT As String = "C:\宁波港"
'
Public Const App_Major = 1
Public Const App_Minor = 0
Public Const App_Revision = 0

'Public Const Color_Blue = &HFF0000
'Public Const Color_Red = &HFF&
'Public Const Color_Yellow = &HFFFF&
'Public Const Color_Green = &HFF00&

'Public PATH_Errlog As String '错误日志路径
Public NameMainMdb  As String  '= "Pizhou.mdb"
Public PATH_Root    As String ' = "D:\邳州港\"
Public PATH_Exe     As String ' = "D:\邳州港\Exe\"
Public PATH_mdb     As String  '= "D:\邳州港\mdb\"'程序数据库路径
Public PATH_Monitor As String  '= "D:\邳州港\exe\Monitor.mdb"  '程序基本数据库

Public Const CN_Str40 As String = _
    "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source="
Public Const Shape_Str40 As String = _
    "Provider=MSDataShape.1;;Connect Timeout=15;Data Provider=MICROSOFT.JET.OLEDB.4.0;Data Source="

Public CN_Monitor As String
Public PATH_Main As String  '= "D:\邳州港\mdb\Pizhou.mdb"      '程序数据库
Public CN_Main As String  '

Public PATH_SB      As String '设备运行时间库


Public Enum EPanel
 stbComm = 1
 stbBanAlias = 3
 stbBanName = 5
End Enum


'--------------------'设置项-------------------------------------------------

Public App_CompanyName   As String '= "淄博张钢公司"
Public COMM_PORT1 As Integer 'XR2001仪表
Public COMM_PORT2 As Integer '调度室通信
Public COMM_PORT3 As Integer '3#泊
Public COMM_PORT4 As Integer '2#泊
Public pMima      As String  '口令
Public pFlowScale As Integer '流量曲线的分度
Public pFlowWidth As Integer '流量曲线线宽

'----------------------------------------------------------------------------
Public SetIni    As CSetting         '参数设置对象
Public SetReg    As CSetting
Public fQM       As frmQM     '主界面
Public fPG2      As frmPG2 'FrmCtl2
Public fPG3      As frmPG3 'FrmCtl3


Public LurName  As String '用户名
Public LurLimit As Long '用户权限
Public LurPwd   As String '用户密码
Public MimaOk   As Boolean
'
Public AppLog  As CAppLog

Public AlarmMarquee As AlarmList

Sub Main()
    
    
    If App.PrevInstance Then
       MsgBox "程序已经存在!" & Chr(13) & Chr(10) _
            & "你可能已经启动了程序或关闭的程序没有完全从后台退出(可以从操作系统任务栏察看).", vbExclamation
       End
    End If
    #If dds <> 2 Then
    If StrComp(CStr(Date), Format$(Date, "YYYY-MM-DD")) <> 0 Then
       MsgBox "本程序认可的日期格式是:YYYY-MM-DD." _
       & vbCr & "与您的电脑上的日期格式不一致,可能导致数据存储日期错误." _
       & vbCr & vbCr & "请在控制面板中修改您的电脑上的日期格式后再运行本程序.", vbCritical
    End If
    #End If
    App.Title = App_Title
   Dim i As Integer
   
    
    NameMainMdb = "JLD" & Format$(Date, "YYYY") & ".mdb" '      '程序数据库
    PATH_Root = App_PATH_ROOT
    
    PATH_Exe = PATH_Root + "\Exe\"
    PATH_mdb = PATH_Root + "\Mdb\"
    PATH_ErrLog = PATH_Exe
    App.HelpFile = PATH_Exe & App_Help
    PATH_Monitor = PATH_Exe + "Monitor.mdb"
    PATH_Main = PATH_mdb + NameMainMdb
    PATH_SB = PATH_mdb + "SB" & Format$(Date, "YYYY") & ".mdb" '设备运行时间库
    '
    SaveSetting App.Title, "路径", "PATH_Exe", PATH_Exe
    SaveSetting App.Title, "路径", "PATH_mdb", PATH_mdb
    SaveSetting App.Title, "路径", "PATH_ErrLog", PATH_ErrLog
    SaveSetting App.Title, "路径", "PATH_Main", PATH_Main
    '
    CN_Monitor = CN_Str40 & PATH_Monitor
    CN_Main = CN_Str40 & PATH_Main '"Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=D:\邳州港\mdb\Pizhou.mdb"
    '
    '=============================
   Set SetIni = New CSetting
   SetIni.Init PATH_Exe, App_Title, csModeINI
   
   Set SetReg = New CSetting
   SetReg.Init PATH_Exe, App_Title, csModeRegistry
   
    '=============================
    '从注册表中取得计数器的值
    Set AppLog = New CAppLog
    #If dds <> 2 Then
    
    If Dir(PATH_Main) = "" Then
        If AppLog.CntAppLog = 0 Then
            CreateMain PATH_Main
               Call CreateSB '设备运行时间库
        Else
          If MsgBox("数据库文件" & vbCr & PATH_Main & vbCr & " 没有建立或丢失!程序不能储存数据!" & Chr(13) & Chr(10) & "要重新创建此文件吗?", vbExclamation + vbYesNo) = vbYes Then
               CreateMain PATH_Main
               
               Call CreateSB '设备运行时间库
               
          Else
              Exit Sub
          End If
          
        End If
    Else
    
    '检测表的存在:tblBanXR
    End If
    If Dir(PATH_Monitor) = "" Then
       If AppLog.CntAppLog = 0 Then  '第一次运行
          CreateMonitor PATH_Monitor
        Else
              If MsgBox("数据库文件 " & vbCr & PATH_Monitor & vbCr & " 没有建立或丢失!程序不能储存数据!" & Chr(13) & Chr(10) & "要重新创建此文件吗?", vbExclamation + vbYesNo) = vbYes Then
                 CreateMonitor PATH_Monitor
              Else
                 Exit Sub
              End If
              
        End If
    Else
    
    '检测表的存在:1.Monitor,2.tblAppLog,3.ur(用户名),4.Cryp,5.Classes,班值名称表
    End If
    
    #End If
    LurName = "超级用户": LurLimit = 32766: MimaOk = True
    AppLog.AppendAppLog eLogType.logApp, App.Title, eLogEvent.logEvApp, eLogRS.LogRSAdd, "进入程序", LurName     '程序日志(.mdb文件)
    
    '----------------------------- 设置项 -----------------------------------------
    App_CompanyName = GetSetting(App.Title, "名称", "公司名称", "宁波港镇海港埠公司")
    COMM_PORT1 = GetSetting(App.Title, Sc_Comm, "秤仪表", 3)   'XR2001仪表
    COMM_PORT2 = GetSetting(App.Title, Sc_Comm, "调度室", 4)  '
    COMM_PORT3 = GetSetting(App.Title, Sc_Comm, "3#泊", 5)   'XR2001仪表
    COMM_PORT4 = GetSetting(App.Title, Sc_Comm, "2#泊", 6)  '
    pMima = GetSetting(App.Title, "设置", "Mima", "KQDLTN") 'KQDLTN=RAMSEY
    pMima = getMima(False, UCase(pMima))
    
'    frmQuery.Show
'    frmRuning.Show
'    Exit Sub
    '----------------------------- 设置项 -----------------------------------------
    modAddr.initAddr '初始化仪表地址
    
    Set fQM = New frmQM
    
    frmSplash.Show
End Sub
Private Sub CreateSB()
   Dim msgYearOk   As String
   Dim Source As String
   Dim destination As String
   Source = PATH_Exe & "\" & "CopySB.mdb": destination = PATH_SB
   If CopyFile(Source, destination, 0) = 0 Then            'FileCopy source, destination
       Call meErr("数据库备份失败!")
   Else
       msgYearOk = Year(Date) & " 年设备运行数据库文件创建完毕." & Chr(13) & Chr(10) _
                  & "谢谢您的合作！" & Chr(13)
       MsgBox msgYearOk, vbOKOnly + vbInformation, "创建 " & Year(Date) & " 年设备运行数据库文件"
   
   End If
End Sub
Public Sub meAutoCopyMDB()
    Static EditState As eEditState '
    Dim bCopyEnabled As Boolean
    On Error Resume Next
  '*****
  If DateDiff("yyyy", Date - 1, Date) = 1 Then '换年
     NameMainMdb = "JLD" & Format$(Date, "YYYY") & ".mdb" '      '程序数据库
     PATH_Main = PATH_mdb + NameMainMdb
     
    PATH_SB = PATH_mdb + "SB" & Format$(Date, "YYYY") & ".mdb" '设备运行时间库
  '
    If Dir(PATH_Main) = "" Then
       CreateMain PATH_Main
       
       Call CreateSB '设备运行时间库
    End If
  End If
     bCopyEnabled = CBool(Weekday(Date) = VbDayOfWeek.vbMonday)
       EditState = meStateChange(EditState, bCopyEnabled)
    If EditState = meEditEnabled Then
    '备份数据库
        Dim Source As String
        Dim destination As String
        Dim strMsg As String
        Source = PATH_mdb & NameMainMdb
        destination = PATH_Root & "\数据库备份\" & NameMainMdb

        If Dir(Source) = "" Then '--------------------------------------------- 1.
            strMsg = "数据库文件: " & Source & " 丢失.备份失败!"
           Call meErr("数据库备份", strMsg, Hour(Time), False) ', , PATH_Errlog)
        Else