البحث في الموقع

السلام عليكم تقبل الله منا و منكم الصلاة و الصيام و القيام إن شاء الله أقدم لكم اليوم كود لضغط و إصلاح قاعدة البيانات الحالية ضع هذا الكود في وحدة نمطية: 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