Assalamualaikum.....
Selamat Pagi semuanya...
Apa kabar ?
Barusan saya browsing guna mencari coding untuk compact and repair
access 2007 with VBA, ternyata malah mendapatkan seperti ini , sudi
kiranya para master memberikan penjelasannya keapada saya ....
koding nya seperti ini :
Sub CompactDbase()
' Requires a reference to be set to
' "Microsoft Jet & Replication Objects Library 2.x"
' (Tools > References and check the reference)
' Requires a form called "startup" with a label called "ProgressLabel"
On Error Goto ErrHandler
' Inform user of progress
Form_StartUp.ProgressLabel.Caption = "Starting Process"
DoEvents
' dimension variables and set
Dim DbaseDir As String
Dim BackupDir As String
Dim DbaseName As String
Dim DbaseTempName As String
Dim DbaseBackupName As String
Dim Dbasebk1 As String
Dim Dbasebk2 As String
Dim Dbasebk3 As String
Dim Dbasebk4 As String
Dim Dbasebk5 As String
' CHANGE SETTINGS IN THIS SECTION TO REUSE THIS PROGRAM
' ###########################################################
DbaseDir = "C:\Database\"
BackupDir = "C:\DbaseBackup\"
DbaseName = "XXX.mdb"
DbaseTempName = "XXXTemp.mdb"
DbaseBackupName = "XXXBackup.mdb"
Dbasebk1 = "XXX1.mdb"
Dbasebk2 = "XXX2.mdb"
Dbasebk3 = "XXX3.mdb"
Dbasebk4 = "XXX4.mdb"
Dbasebk5 = "XXX5.mdb"
' ###########################################################
Form_StartUp.ProgressLabel.Caption = "Initial Backup started. " & DbaseBackupName
DoEvents
' Perform Backup before starting
FileCopy DbaseDir & DbaseName, _
DbaseDir & DbaseBackupName
Dim je As New JRO.JetEngine
' Kill previous Temp file
If Dir(DbaseDir & DbaseTempName) <> "" Then _
Kill DbaseDir & DbaseTempName
' Compact dbase to dbaseTemp
Form_StartUp.ProgressLabel.Caption = "Compacting started. " & DbaseTempName
DoEvents
je.CompactDatabase _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DbaseDir & DbaseName, _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DbaseDir & DbaseTempName & ";"
' Delete dbase
Form_StartUp.ProgressLabel.Caption = "Replacing compact file " & DbaseName
DoEvents
Kill DbaseDir & DbaseName
' Rename dbaseTemp (now compacted) to dbase
Name DbaseDir & DbaseTempName _
As DbaseDir & DbaseName
' Resuffle backups and backup current
Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk5
DoEvents
If Dir(BackupDir & Dbasebk5) <> "" Then
Kill BackupDir & Dbasebk5
End If
Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk4
DoEvents
If Dir(BackupDir & Dbasebk4) <> "" Then
Name BackupDir & Dbasebk4 _
As BackupDir & Dbasebk5
End If
Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk3
DoEvents
If Dir(BackupDir & Dbasebk3) <> "" Then
Name BackupDir & Dbasebk3 _
As BackupDir & Dbasebk4
End If
Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk2
DoEvents
If Dir(BackupDir & Dbasebk2) <> "" Then
Name BackupDir & Dbasebk2 _
As BackupDir & Dbasebk3
End If
Form_StartUp.ProgressLabel.Caption = "Resuffling backups " & Dbasebk1
DoEvents
If Dir(BackupDir & Dbasebk1) <> "" Then
Name BackupDir & Dbasebk1 _
As BackupDir & Dbasebk2
End If
FileCopy DbaseDir & DbaseName, _
BackupDir & Dbasebk1
Form_StartUp.ProgressLabel.Caption = "Process info"
DoEvents
Exit Sub
ErrHandler:
MsgBox ("Error message here - Your first time ? Did you forget to hold down shift key ?")
End Sub
Public Function CompactBackupdbase()
' Allows sub to be visible from macros
Call CompactDbase
End Function
Terima kasih
--
Best regards,
access
mailto:access_tea@yahoo.co.id
Tidak ada komentar:
Posting Komentar