?? 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 + -