امكانية تحويل ملف اكسس خلال النسخ الاحتياطي الى ملف مظغوط RAR

[محمد التميمي]

السلام عليكم 

لدي في المثال المرفق كود للنسخ الاحتياطي قام بكتابته الاخ الكريم  د . كاف يار على ما اعتقد

المطلوب

هل هناك امكانية تحويل ملف الاكسس  خلال عملية النسخ الاحتياطي الى ملف مضغوط RAR بالتعديل على الكود الموجود في زر الامر

مع الشكر

New.rar

[د.كاف يار]

تفضل هذا التعديل 

 

اولاً / في رأس الصفحة ضع الأوامر التالية

Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

ثانيا / انسخ الكود ادناه و ضعه في حدث الأزرار عند النقر

On Error GoTo ErrH
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Set fso = CreateObject("scripting.filesystemobject")
          fldrpath = CurrentProject.Path & "\Backup"
          If Not fso.FolderExists(fldrpath) Then
             fso.createfolder (fldrpath)
             DoCmd.RunSQL "CREATE TABLE Backup (Backup_NO INT , Backup_Name VARCHAR (50) , Backup_Path VARCHAR (100), Backup_Date Date);"

          End If
Dim MyFile, DstFile As String
Dim Syso As Object

MyFile = CurrentProject.FullName
DstFile = CurrentProject.Path & "\Backup\Backup-" & Format(Now, "dd-mm-yyyy") & "-" & Format(Now, "hh-nn-ss") & ".accdb"

DBEngine.Idle

Set Syso = CreateObject("Scripting.FileSystemObject")
Syso.copyfile MyFile, DstFile
Set Syso = Nothing

Name DstFile As DstFile & ".ptc"
DBEngine.CompactDatabase DstFile & ".ptc", DstFile
Kill DstFile & ".ptc"
Dim db As DAO.Database
Dim MaxBackup_NO As Integer
MaxBackup_NO = Nz(DMax("[Backup_NO]", "[Backup]"), 0) + 1
    Dim rs As DAO.Recordset
    Set db = CurrentDb
Set rs = db.OpenRecordset("Backup")
    With rs
        .AddNew
        ![Backup_NO] = MaxBackup_NO
        ![Backup_Name] = Format(Now, "dd-mm-yyyy") & "-" & Format(Now, "hh-nn-ss")
        ![Backup_Path] = DstFile
        ![Backup_Date] = Now()
        .Update

    End With
    rs.Close
    Set rs = Nothing
'=================================
    Dim ShellApplication    As Object

    Dim CurrentProjectFile  As String
    Dim ZipPath             As String
    Dim ZipName             As String
    Dim ZipFile             As String
    Dim FileNumber          As Integer

    CurrentProjectFile = DstFile
    ZipPath = CurrentProject.Path & "\Backup\BackupZip" & Format(Now, " yyyy-mm-dd hh.nn.ss") & "\"
    ZipName = "Backup.zip"
    ZipFile = ZipPath & ZipName
    If Dir(ZipPath, vbDirectory) = "" Then
        MkDir ZipPath
    End If

    FileNumber = FreeFile
    Open ZipFile For Output As #FileNumber
    Print #FileNumber, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
    Close #FileNumber

    Set ShellApplication = CreateObject("Shell.Application")
    With ShellApplication
        Debug.Print Timer, "zipping started ..."
        .Namespace(CVar(ZipFile)).CopyHere CVar(CurrentProjectFile)
        On Error Resume Next
        Do Until .Namespace(CVar(ZipFile)).Items.Count = 1
            Sleep 100
            Debug.Print " .";
        Loop
        Debug.Print
        On Error GoTo 0
        Debug.Print Timer, "zipping finished."
    End With
    Set ShellApplication = Nothing
        Kill DstFile
'==========================================

MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "dd-mm-yyyy") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد"


Exit Sub
ErrH:
Select Case Err.Number
End Select

 

تم تعديل يوليو 2, 2021 بواسطه د.كاف يار

[محمد التميمي]

5 ساعات مضت, د.كاف يار said:

تفضل هذا التعديل 

 

اولاً / في رأس الصفحة ضع الأوامر التالية

Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

ثانيا / انسخ الكود ادناه و ضعه في حدث الأزرار عند النقر

On Error GoTo ErrH
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
Set fso = CreateObject("scripting.filesystemobject")
          fldrpath = CurrentProject.Path & "\Backup"
          If Not fso.FolderExists(fldrpath) Then
             fso.createfolder (fldrpath)
             DoCmd.RunSQL "CREATE TABLE Backup (Backup_NO INT , Backup_Name VARCHAR (50) , Backup_Path VARCHAR (100), Backup_Date Date);"

          End If
Dim MyFile, DstFile As String
Dim Syso As Object

MyFile = CurrentProject.FullName
DstFile = CurrentProject.Path & "\Backup\Backup-" & Format(Now, "dd-mm-yyyy") & "-" & Format(Now, "hh-nn-ss") & ".accdb"

DBEngine.Idle

Set Syso = CreateObject("Scripting.FileSystemObject")
Syso.copyfile MyFile, DstFile
Set Syso = Nothing

Name DstFile As DstFile & ".ptc"
DBEngine.CompactDatabase DstFile & ".ptc", DstFile
Kill DstFile & ".ptc"
Dim db As DAO.Database
Dim MaxBackup_NO As Integer
MaxBackup_NO = Nz(DMax("[Backup_NO]", "[Backup]"), 0) + 1
    Dim rs As DAO.Recordset
    Set db = CurrentDb
Set rs = db.OpenRecordset("Backup")
    With rs
        .AddNew
        ![Backup_NO] = MaxBackup_NO
        ![Backup_Name] = Format(Now, "dd-mm-yyyy") & "-" & Format(Now, "hh-nn-ss")
        ![Backup_Path] = DstFile
        ![Backup_Date] = Now()
        .Update

    End With
    rs.Close
    Set rs = Nothing
'=================================
    Dim ShellApplication    As Object

    Dim CurrentProjectFile  As String
    Dim ZipPath             As String
    Dim ZipName             As String
    Dim ZipFile             As String
    Dim FileNumber          As Integer

    CurrentProjectFile = DstFile
    ZipPath = CurrentProject.Path & "\Backup\BackupZip" & Format(Now, " yyyy-mm-dd hh.nn.ss") & "\"
    ZipName = "Backup.zip"
    ZipFile = ZipPath & ZipName
    If Dir(ZipPath, vbDirectory) = "" Then
        MkDir ZipPath
    End If

    FileNumber = FreeFile
    Open ZipFile For Output As #FileNumber
    Print #FileNumber, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, vbNullChar)
    Close #FileNumber

    Set ShellApplication = CreateObject("Shell.Application")
    With ShellApplication
        Debug.Print Timer, "zipping started ..."
        .Namespace(CVar(ZipFile)).CopyHere CVar(CurrentProjectFile)
        On Error Resume Next
        Do Until .Namespace(CVar(ZipFile)).Items.Count = 1
            Sleep 100
            Debug.Print " .";
        Loop
        Debug.Print
        On Error GoTo 0
        Debug.Print Timer, "zipping finished."
    End With
    Set ShellApplication = Nothing
        Kill DstFile
'==========================================

MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "dd-mm-yyyy") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد"


Exit Sub
ErrH:
Select Case Err.Number
End Select

 

صباح الخير استاذي الكريم  د.كاف يار شكرا على المرور بسؤالي

اجريت الازم على الكود حسب تعليماتك ولاكن كان عمله كالاتي

انتج نسخ احتياطي ولاكن ( الباكب غير مضغوط ) بحسب الصورة المرفقة

لم تظهر اي رسالة مثل ( تم انشاء قاعدة البيانات بنجاح )

[د.كاف يار]

تفضل هذا المثال

 

1MyData.zip

[محمد التميمي]

44 دقائق مضت, د.كاف يار said:

تفضل هذا المثال

 

وقفت بجانبي حتى احقق افكاري وكل ما اتمنى دون ان تنتظر مني اي مقابل واود ان اقول لك شكراً جزيلاً