كود ضغط و إصلاح قاعدة البيانات الحالية

[صالح حمادي]

السلام عليكم

تقبل الله منا و منكم الصلاة و الصيام و القيام إن شاء الله

أقدم لكم اليوم  كود لضغط و إصلاح قاعدة البيانات الحالية

ضع هذا الكود في وحدة نمطية:

Function Allenda_Compact()
'On Error Resume Next
Dim mdb_Path_Name As String
Dim wrkAcc As Object
Dim dbsNew As Object
Dim file_data As String
Dim app As Access.Application
Dim frm As Form
Dim crt As Control
Dim old_name_frm As String
Dim new_name_frm As String
Dim str_code As String
Dim name_new_db As String
Dim name_old_db As String

name_new_db = Application.CurrentProject.Path & "\prog-comp.accdb"
name_old_db = Application.CurrentDb.Name
'----------------------------------------------------------إنشاء ملف أكسس جديد
mdb_Path_Name = Environ("Temp") & "\compact-repair.accdb"
Set wrkAcc = CreateWorkspace("AccessWorkspace", "admin", "", dbUseJet)
If Dir(mdb_Path_Name) <> "" Then Kill mdb_Path_Name
Set dbsNew = wrkAcc.CreateDatabase(mdb_Path_Name, dbLangGeneral)
dbsNew.Close
wrkAcc.Close
'---------------------------------------------------------------------------إنشاء نموذج
Set app = CreateObject("Access.Application")
app.OpenCurrentDatabase (mdb_Path_Name)
app.Visible = False 'True
Set frm = app.CreateForm
old_name_frm = frm.Name
new_name_frm = "form01"
app.DoCmd.Save acForm, old_name_frm
app.DoCmd.Close acForm, old_name_frm
app.DoCmd.Rename new_name_frm, acForm, old_name_frm
'--------------------------------------------------------------------------- اضافة الكود للنموذج المنجز
app.DoCmd.OpenForm new_name_frm, acDesign

'Set crt = app.CreateControl(new_name_frm, acCommandButton, acDetail, , , L, t, "3000", "1000")
 'crt.Caption = "compact and repair"
str_code = "Dim x As Integer" & vbCrLf & _
  "Private Sub Form_Timer()" & vbCrLf & _
  "FileCopy " & Chr(34) & name_old_db & Chr(34) & " , " & Chr(34) & name_new_db & Chr(34) & vbCrLf & _
  "Kill " & Chr(34) & name_old_db & Chr(34) & vbCrLf & _
  "Set acc2007 = CreateObject(" & Chr(34) & "DAO.DBEngine.36" & Chr(34) & ")" & vbCrLf & _
  "acc2007.CompactDatabase " & Chr(34) & name_new_db & Chr(34) & ", " & Chr(34) & name_old_db & Chr(34) & ", Nothing, Nothing" & vbCrLf & _
  "Set acc2007 = Nothing" & vbCrLf & _
  "Kill " & Chr(34) & name_new_db & Chr(34) & vbCrLf & _
  "Application.FollowHyperlink " & Chr(34) & name_old_db & Chr(34) & vbCrLf & _
  "Quit" & vbCrLf & _
  "End Sub" & vbCrLf & _
  "Private Sub Form_Load()" & vbCrLf & _
  "Dim db As Object" & vbCrLf & _
  "Set db = GetObject(" & Chr(34) & name_old_db & Chr(34) & ")" & vbCrLf & _
  "db.Quit" & vbCrLf & _
  "Set db = Nothing" & vbCrLf & _
  "Me.TimerInterval = 500" & vbCrLf & _
  "End Sub"
  
  app.Forms(new_name_frm).Module.AddFromString str_code
  app.DoCmd.Close acForm, new_name_frm, acSaveYes
  app.Quit acQuitSaveAll
Set app = Nothing
DoCmd.TransferDatabase acExport, "Microsoft Access", mdb_Path_Name, acMacro, "Autoexec1", "Autoexec", False
Application.FollowHyperlink mdb_Path_Name
End Function

و نقوم بإستدعائها من خلال هذا الكود خلف زر أمر

Allenda_Compact

يوجد ماكرو في المرفقات اسمه Autoexec1 نقوم بنقله للقاعدة التي نريد ضغطها و إصلاحها.

أرجوا تجربة المرفق و إعلامنا بالنتائج

ضغط و إصلاح قاعدة البيانات الحالية.rarFetching info...

[ابو جودي]

طيب جرب هاد المرفق  
للعلم هذا من مكتبتى ولا ادرى اواتذكر من اين حصلته

بصراحة المرفق تبعك لم يعمل معى اوفيس 2019  32 بيت

  Compact.accdbFetching info...

[صالح حمادي]

  في 14‏/5‏/2019 at 22:11, ابا جودى said:

طيب جرب هاد المرفق  
للعلم هذا من مكتبتى ولا ادرى اواتذكر من اين حصلته

Expand  

أهلين أخي أبا جودي

المرفق إشتغل معي بشكل جيد

لكن عندما نقلت الكود إلى ملف بصيغة 2003 آخر لم يشتغل معي

غير صيغة الملف إلى 2007 اشتغل الكود

  في 14‏/5‏/2019 at 22:11, ابا جودى said:

بصراحة المرفق تبعك لم يعمل معى اوفيس 2019  32 بيت

Expand  

أنا عملته على أكسس 2010

ما هو الخطأ الذي ظهر معك