mdlmain.bas

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

            If Dir(PATH_Root & "\数据库备份\", vbDirectory) = "" Then '--- 2.
                 CreateNewDirectory (PATH_Root & "\" & "数据库备份")
            End If
            If CopyFile(Source, destination, 0) = 0 Then            'FileCopy source, destination
                Call meErr("数据库备份", "备份数据失败!", Hour(Time), False) ', , PATH_Errlog)
            End If
         End If '------------------------------------------------------------ 1.

    End If
End Sub

Private Sub CreateMain(ByVal PathMain As String)
        Dim PathDir As String
        Dim Loc     As Long
        
        On Error GoTo err1
        Loc = InStrRev(PathMain, "/")
        If Loc = 0 Then
        Loc = InStrRev(PathMain, "\") '验证路径字符串
        End If
        PathDir = Mid(PathMain, 1, Loc - 1)
        If Dir(PathDir, vbDirectory) = "" Then
            CreateNewDirectory PathDir                      '创建目录
        End If
         
        CreateTableDef_DataBase PathMain            '创建数据库
        
        Call CreateTableDef_tblBanXR(PATH_Main, "idx")     '创建班表
        Call CreateTableDef_tblRuning(PATH_Main, "tblRuning", "idx")  '创建皮带运行表
        Exit Sub
err1:
        Call meErr("CreateMain", Err.Description) ', , , , PATH_Errlog)
        Err.Clear
        Resume Next
End Sub

Private Sub CreateMonitor(ByVal PathMonitor As String)
        Dim PathDir As String
        Dim Loc     As Long
        
        On Error GoTo err1
        Loc = InStrRev(PathMonitor, "/")
        If Loc = 0 Then
        Loc = InStrRev(PathMonitor, "\") '验证路径字符串
        End If
        PathDir = Mid(PathMonitor, 1, Loc - 1)
        If Dir(PathDir, vbDirectory) = "" Then
            CreateNewDirectory PathDir                      '创建目录
        End If
         
        CreateTableDef_DataBase PATH_Monitor             '创建数据库
        CreateTableDef_tblAppLog PATH_Monitor, "tblAppLog"
'        Call CreateTableDef_Monitor(PATH_Monitor, "Monitor")         '创建程序监控表
        Call CreateTableDef_tblUr(PATH_Monitor)                       '创建用户管理表
'        Call CreateTableDef_tblProportion(PATH_Monitor, "Idx配比")
        
        
        Exit Sub
err1:
        Call meErr("CreateMonitor", Err.Description) ', , , , PATH_Errlog)
        Err.Clear
        Resume Next
        
End Sub

Public Property Let msgBar(ByVal Panel As EPanel, ByVal msg As String)
    On Error Resume Next
    'frmMDI.StatusBar1.Panels(Panel).Text = msg
End Property
Public Function UserLimit(ByVal Func As Variant) As Boolean
   Const Con1 As String = "参数设置" '1'参数设置
   Const Con2 As String = "仪表设定" '6
   Const Con3 As String = "用户管理" '8
   Const Con4 As String = "密码修改" '2
   Const Con5 As String = "系统退出" '11
   Const Con6 As String = "班次设定" '7
   Const Con7 As String = "配比操作" '3
   Const Con8 As String = "配料称启停" '12
   Dim bLimit As Boolean
   On Error Resume Next
    Select Case Func
        Case Con1, 1
             bLimit = CBool((LurLimit And 2 ^ 1) / (2 ^ 1))
        Case Con2, 6
             bLimit = CBool((LurLimit And 2 ^ 6) / (2 ^ 6))
        Case Con3, 8
             bLimit = CBool((LurLimit And 2 ^ 8) / (2 ^ 8))
        Case Con4, 2
             bLimit = CBool((LurLimit And 2 ^ 2) / (2 ^ 2))
        Case Con5, 11
             bLimit = CBool((LurLimit And 2 ^ 11) / (2 ^ 11))
        Case Con6, 7
             bLimit = CBool((LurLimit And 2 ^ 7) / (2 ^ 7))
        Case Con7, 3
             bLimit = CBool((LurLimit And 2 ^ 3) / (2 ^ 3))
        Case Con8, 12
             bLimit = CBool((LurLimit And 2 ^ 12) / (2 ^ 12))
   End Select
   
   UserLimit = bLimit
   
End Function
Public Sub FreshBcCombo(combo As ComboBox)
   Dim cn As ADODB.Connection
   Dim CnString As String
   On Error GoTo err1
   'Open Connection
   Set cn = New ADODB.Connection
   CnString = CN_Str40 & PATH_Exe & "bc.mdb"
   cn.Open CnString
   FillCombo cn, combo, "bc", "bc"
exitSub:
    cn.Close
    Set cn = Nothing
    combo.ToolTipText = "班次"
    Exit Sub
err1:
    Call meErr("FreshBcCombo", Err.Description)
    Err.Clear
    Resume Next
End Sub

Public Sub FreshUserCombo(cboBox As ComboBox)
   Dim cn As ADODB.Connection
   Dim CnString As String
   On Error GoTo err1
   'Open Connection
   Set cn = New ADODB.Connection
   CnString = CN_Monitor
   cn.Open CnString
   
   'Open the Database
'    Set db = DBEngine.Workspaces(0).OpenDatabase(PATH_Denlu)
    FillCombo cn, cboBox, "ur", "用户"
    cn.Close
exitSub:
    Set cn = Nothing
    Exit Sub
err1:
    Call meErr("FreshUserCombo", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume Next
End Sub

Private Sub FillCombo(Conn As ADODB.Connection, cboBox As ComboBox, strTB As String, descField As String)
'Private Sub FillCombo(cboBox As ComboBox, strTB As String, descField As String)
   Dim rs As ADODB.Recordset   'Declare a recordset
   Dim sql As String   'Declare a string to hold the SQL statement
   
   On Error GoTo Errors
   
   cboBox.Clear
   cboBox.ToolTipText = descField
   
   sql = ""
   sql = "SELECT " & descField & " FROM " & strTB
   'Open table
   Set rs = Conn.Execute(sql)
   
   
   With rs
      
      Do Until .EOF 'Loop until the End of the recordset
         
         cboBox.AddItem rs(descField).Value
         .MoveNext
      
      Loop
      
      .Close
      
      
   End With '(rs)
exitSub:
   Set rs = Nothing 'Release the variable
   
   Exit Sub

Errors: 'Error handler
  
If Err.Number <> 0 Then

    Call meErr("FillCombo", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub

End If

End Sub



Public Function getMima(ByVal jm As Boolean, ByVal Mima As String) As String
Const va = 64
Const jm1 As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const jm2 As String = "QWERTYUIOPASDFGHJKLZXCVBNM"
Dim xm As String, ym As String
Dim Loc As Integer, sm As String * 1
Dim seekLoc As Integer
Dim vm As String
Dim mm As String
mm = UCase(Mima)
If jm Then
    xm = jm1: ym = jm2
Else
    xm = jm2: ym = jm1
End If

For Loc = 1 To Len(mm)
    sm = Mid(mm, Loc, 1)
    seekLoc = InStr(1, xm, sm)
    sm = Mid(ym, seekLoc, 1)
    vm = vm & sm
Next Loc
getMima = vm
End Function

Public Sub mePauseX(Optional ByVal delayTime As Single = 0.68)   'delayTime:延迟时间
  Dim oldTime As Single, newTime As Single
  oldTime = Timer
  newTime = oldTime + delayTime
  Do While newTime > Timer
   If Timer < 3 Then Exit Do
   DoEvents
  Loop
End Sub