تم تعديل الكود والتأكد منه وتجربته . انسخه إلى مديول جديد ، واستدعيه بالأمر : ( CopactMyDb )
فقط حدد اسم قاعدة البيانات الخلفية التي بجانب القاعدة الرئيسية .
Public Function compactDb(ByVal mydb As String, ByVal mydbb As String, ByVal mypass As String, Optional openIt As Boolean = False)
Dim f As Integer
Dim filenoext As String, extension As String, Access As String
Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE"""
filenoext = Left(mydb, InStrRev(mydb, "."))
extension = Right(mydb, Len(mydb) - InStrRev(mydb, "."))
f = FreeFile
Open CurrentProject.Path & "\compact.bat" For Output As f
Print #f, "CHCP 1256"
Print #f, ":checkldb1"
Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb1"
Print #f, Access & " """ & mydbb & """" & mypass & " /compact"
If openIt Then
Print #f, ":checkldb2"
Print #f, "if exist """ & filenoext & "l" & extension & """ goto checkldb2"
Print #f, Access & " """ & mydb & """"
Else
Print #f, "del ""%~f0"""
End If
Close f
End Function
Public Function CopactMyDb()
On Error Resume Next
Dim Mypath, CurrDB, BEndTBL As String
BEndTBL = "B-TBL.accdb" 'اسم قاعدة البيانات الخلفية
CurrDB = CurrentProject.Path & "\" & CurrentProject.Name
Mypath = CurrentProject.Path & "\" & BEndTBL
Call compactDb(CurrDB, Mypath, "", True)
Shell """" & Left(Mypath, InStrRev(Mypath, "\")) & "\compact.bat""", 0
DoCmd.Quit acQuitSaveAll
End Function
Desktop.zip