اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

السلام عليكم

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

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

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

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 نقوم بنقله للقاعدة التي نريد ضغطها و إصلاحها.

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

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

رابط هذا التعليق
شارك

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

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

 Compact.accdb

  • Like 1
رابط هذا التعليق
شارك

38 دقائق مضت, ابا جودى said:

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

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

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

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

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

38 دقائق مضت, ابا جودى said:

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

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

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information