📄 frmsys.frm
字号:
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -