Other Databases

Development Platform:
Visual Basic

frmSys.frm：Code Content
							VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmSys 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "系统数据库管理"
   ClientHeight    =   3690
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6225
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmSys.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3690
   ScaleWidth      =   6225
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton cmdSys 
      Height          =   525
      Index           =   1
      Left            =   3517
      Picture         =   "frmSys.frx":000C
      Style           =   1  'Graphical
      TabIndex        =   12
      Top             =   390
      Width           =   1830
   End
   Begin VB.CommandButton cmdSys 
      Height          =   525
      Index           =   0
      Left            =   877
      Picture         =   "frmSys.frx":232C
      Style           =   1  'Graphical
      TabIndex        =   11
      Top             =   390
      Width           =   1830
   End
   Begin VB.CommandButton cmdSys 
      Height          =   525
      Index           =   2
      Left            =   3517
      Picture         =   "frmSys.frx":4365
      Style           =   1  'Graphical
      TabIndex        =   10
      Top             =   1357
      Width           =   1830
   End
   Begin VB.CommandButton cmdSys 
      Height          =   525
      Index           =   4
      Left            =   3517
      Picture         =   "frmSys.frx":675A
      Style           =   1  'Graphical
      TabIndex        =   9
      Top             =   2325
      Width           =   1830
   End
   Begin VB.CommandButton cmdSys 
      Height          =   525
      Index           =   5
      Left            =   877
      Picture         =   "frmSys.frx":8B51
      Style           =   1  'Graphical
      TabIndex        =   7
      Top             =   2325
      Width           =   1830
   End
   Begin ComctlLib.StatusBar stbMain 
      Align           =   2  'Align Bottom
      Height          =   405
      Left            =   0
      TabIndex        =   6
      Top             =   3285
      Width           =   6225
      _ExtentX        =   10980
      _ExtentY        =   714
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   1
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   10927
            Text            =   ""
            TextSave        =   ""
            Key             =   ""
            Object.Tag             =   ""
            Object.ToolTipText     =   "提示"
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton cmdSys 
      BackColor       =   &H00C0C0C0&
      Height          =   525
      Index           =   3
      Left            =   877
      Picture         =   "frmSys.frx":AB59
      Style           =   1  'Graphical
      TabIndex        =   0
      Top             =   1357
      Width           =   1830
   End
   Begin VB.Label lblMsg 
      AutoSize        =   -1  'True
      Caption         =   "缩小系统数据库的大小,提高系统的运行速度(可经常使用)"
      Height          =   210
      Index           =   5
      Left            =   1020
      TabIndex        =   8
      Top             =   2865
      Visible         =   0   'False
      Width           =   5355
   End
   Begin VB.Label lblMsg 
      AutoSize        =   -1  'True
      Caption         =   "返回主界面"
      Height          =   210
      Index           =   4
      Left            =   3225
      TabIndex        =   5
      Top             =   4125
      Visible         =   0   'False
      Width           =   1050
   End
   Begin VB.Label lblMsg 
      Caption         =   "删除在选定时间之前的过期信息(注意：应先作好备份!!)"
      Height          =   210
      Index           =   3
      Left            =   585
      TabIndex        =   4
      Top             =   5175
      Visible         =   0   'False
      Width           =   11130
   End
   Begin VB.Label lblMsg 
      AutoSize        =   -1  'True
      Caption         =   "清空所有考勤的数据.(尤可在备份后,用于新季度的开始.)"
      Height          =   210
      Index           =   2
      Left            =   705
      TabIndex        =   3
      Top             =   4575
      Visible         =   0   'False
      Width           =   5355
   End
   Begin VB.Label lblMsg 
      AutoSize        =   -1  'True
      Caption         =   "备份数据库(应经常性使用!)"
      Height          =   210
      Index           =   0
      Left            =   2355
      TabIndex        =   2
      Top             =   3570
      Visible         =   0   'False
      Width           =   2625
   End
   Begin VB.Label lblMsg 
      AutoSize        =   -1  'True
      Caption         =   "初始化系统数据库!(注意:所有用户数据都将丢失!!)"
      Height          =   210
      Index           =   1
      Left            =   1140
      TabIndex        =   1
      Top             =   3285
      Visible         =   0   'False
      Width           =   4830
   End
End
Attribute VB_Name = "frmSys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const mCopy = 0
Const mEmpty = 1
Const mDetailEmpty = 2
Const mClearOld = 3
Const mReturn = 4
Const mCompress = 5
Const mCRLF = vbCrLf & vbCrLf
Const mEMPTYDATABASE = "Empty.mdb"
Dim mMyAppPath As String
Private Sub cmdSys_Click(Index As Integer)
    Select Case Index
        Case mCopy
            BackDatabase
        Case mEmpty
            IniDatabase
        Case mDetailEmpty
            DetailEmpty
        Case mClearOld
            ClearOld
        Case mReturn
            Unload Me
        Case mCompress
            CompressDatabase
    End Select
End Sub
Private Sub ClearOld()
    Dim Sql As String
    Dim isTrans As Boolean
    
    Dim UserDate As Date
    Dim strDate As String
    Dim Fr As frmCalendar
    Set Fr = New frmCalendar
    UserDate = Date
    With cmdSys(mClearOld)
        Fr.Top = Me.Top + .Top + .Height
        Fr.Left = Me.Left + .Left + .Width - Fr.Width
        '.Show 1
    End With
    If Fr.GetDate(UserDate) Then
        strDate = Format(UserDate, "yyyy-mm-dd")
    End If
    On Error GoTo ClearErr
    If MsgBox("真的要删除" & Format(strDate, "yyyy年mm月dd日") _
        & "以前的所有考勤记录吗？" _
        , vbExclamation + vbYesNo + _
        vbDefaultButton2, gTitle) = vbNo Then Exit Sub
    BeginTrans
    isTrans = True
    Sql = " delete * from " & "KqHistory" _
        & " Where KqDate<=#" & strDate & "#"
    gDataBase.Execute Sql
    
    Sql = " delete * from " & "Leave" _
        & " Where EndDate<=#" & strDate & "#"
    gDataBase.Execute Sql
    
    Sql = "Delete * from Absent " _
        & " Where EndDate<=#" & strDate & "#"
    gDataBase.Execute Sql
    CommitTrans
    isTrans = False
    
    MsgBox "删除过期信息成功！", vbInformation, gTitle
    
    Exit Sub
ClearErr:
    If isTrans Then Rollback
    MsgBox Err.Description, vbExclamation, gTitle
    Err.Clear
End Sub
Private Sub DetailEmpty()
    Dim Sql As String
    Dim isTrans As Boolean
    
    If MsgBox("注意操作危险，此举将清空数据库所有考勤记录!!!" & _
        mCRLF & "您真的要进行此操作吗？ " _
        , vbExclamation + vbYesNo + vbDefaultButton2, _
        gTitle) = vbNo Then Exit Sub
    On Error GoTo EmptyErr
    
    BeginTrans
    isTrans = True
    Sql = " delete * from " & "KqHistory"
    gDataBase.Execute Sql
    Sql = " delete * from " & "Leave"
    gDataBase.Execute Sql
    Sql = "DElete * from Absent"
    gDataBase.Execute Sql
    
    CommitTrans
    isTrans = False
    MsgBox "清空考勤记录成功！", vbInformation, "提示"
    Exit Sub
EmptyErr:
    If isTrans Then Rollback
    MsgBox Err.Description, vbExclamation, gTitle
    Err.Clear
End Sub
Private Sub CompressDatabase()
    If Not ClearDelFlag Then Exit Sub
    Dim FileName As String
    Dim FileNew As String
    Dim Info As String
    Dim bIsTrue As Boolean
    
    gDataBase.Close
    FileName = gMainDbName
    FileNew = mMyAppPath & "NewKq.mdb"
    bIsTrue = ComPactData(FileName, FileNew)
    If bIsTrue Then
        Kill FileName
        Name FileNew As FileName
        MsgBox "压缩数据库成功！", vbInformation, gTitle
    End If
    OpenData
End Sub
Public Function ClearDelFlag() As Boolean
    Dim Sql As String
    Dim isTrans As Boolean
    Dim MyTab As TableDef
    On Error GoTo DelErr
    BeginTrans
    isTrans = True
    
    For Each MyTab In gDataBase.TableDefs
        
        If MyTab.Attributes = 0 Then
            Sql = "delete * from " & MyTab.Name _
                & " Where F_DelFlag=" & gTRUE
            gDataBase.Execute Sql
        End If
    Next
    CommitTrans
    ClearDelFlag = True
    isTrans = False
    Exit Function
DelErr:
    If isTrans Then Rollback
    MsgBox Err.Description, vbExclamation, gTitle
    ClearDelFlag = False
    Err.Clear
End Function
Private Function ComPactData(SourceName As String, NewName As String) As Boolean
    On Error GoTo Err_Compact
        If Dir(NewName) <> "" Then Kill NewName
        DBEngine.CompactDatabase SourceName, NewName, , , ";pwd=" & gSTRPWD
        ComPactData = True
        Exit Function
Err_Compact:
    MsgBox Err.Description
    ComPactData = False
    Err.Clear
End Function
Private Sub cmdSys_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    stbMain.Panels(1).Text = lblMsg(Index)
    cmdSys(Index).ToolTipText = lblMsg(Index)
End Sub
Private Sub SetstbMain(Index As Integer, strText As String)
    stbMain.Panels(Index).Text = strText
End Sub
Private Sub BackDatabase()
    Dim FileName As String
    Dim FileBack As String
    Dim Info As String
    
    gDataBase.Close
    
    FileName = gMainDbName
    FileBack = mMyAppPath & "Kq.Abk"
    Info = "正在备份数据库" & FileName
    BackupDatabase FileName, FileBack, Info
    MsgBox "备份数据库成功！", vbInformation, gTitle
    OpenData
End Sub
Private Sub BackupDatabase(SourceName As String, BackupName As String, Info As String)
'备份数据库
    On Error Resume Next
    SetstbMain 1, Info & "..."
    If Dir(BackupName) <> "" Then Kill BackupName
    FileCopy SourceName, BackupName
    On Error GoTo 0
    SetstbMain 1, ""
End Sub
Private Sub IniDatabase()
    If MsgBox("注意操作危险，将清空数据库所有用户数据！！！" & _
            mCRLF & "您真的要进行此操作吗？", vbExclamation + vbYesNo + vbDefaultButton2, _
            "清空数据库") = vbNo Then Exit Sub
    If Dir(mMyAppPath & mEMPTYDATABASE) = "" Then
        MsgBox "系统初始化数据库空库丢失！", vbExclamation, "出错"
        Exit Sub
    End If
    
    On Error Resume Next
    gDataBase.Close
    Set gDataBase = OpenDatabase(mMyAppPath & mEMPTYDATABASE, False, False, ";pwd=" & gSTRPWD)
    If Err = 3031 Then
        MsgBox "数据库 " & mMyAppPath & mEMPTYDATABASE & " 的密码不符！", vbCritical, "出错"
        Set gDataBase = OpenDatabase(gMainDbName, False, False, ";pwd=" & gSTRPWD)
        Exit Sub
    ElseIf Err <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If
    On Error GoTo 0
    gDataBase.Close
    On Error Resume Next
    FileCopy mMyAppPath & mEMPTYDATABASE, gMainDbName
    If Err = 70 Then
        Err = 0
        MsgBox "有其他工作站正在使用本系统数据库！" & mCRLF & "请在其他时间再使用本功能!", vbExclamation, "资源冲突"
        Set gDataBase = OpenDatabase(gMainDbName, False, False, ";pwd=" & gSTRPWD)
        Exit Sub
    End If
    On Error GoTo 0
    Set gDataBase = OpenDatabase(gMainDbName, False, False, ";pwd=" & gSTRPWD)
    MsgBox "初始化数据库成功！", vbInformation, gTitle
End Sub
Private Sub OpenData()
    Set gDataBase = OpenDatabase(gMainDbName, False, False, ";pwd=" & gSTRPWD)
End Sub
Private Sub Form_Load()
    mMyAppPath = App.Path & "Data"
End Sub

						