نجوم المشاركات

تم تعديل الكود والتأكد منه وتجربته . انسخه إلى مديول جديد ، واستدعيه بالأمر : ( 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

وعليكم السلام ورحمه الله وبركاته تفضل جرب هذا التعديل ارسال واتساب .xlsm