كود النسخ الاحتياطي مطلوب تعديل على كود النسخ الاحتياطي لكي يحفظ في الدي داخل مجلد

[ابوعلي الحبيب]

مطلوب تعديل على كود النسخ الاحتياطي لكي يحفظ في الدي داخل مجلد

السلام عليكم

إخوتي أساتذتي أعضاء منتدى أفيسنا

اريد تعديل مكان الحفظ الى الدي  
ويقوم بانشاء مجلد تلقائي 
باسم مجلد النسخ الاحتياطية 

ويحفظ الملفات كل واحد باسمه مع وقت وتاريخ الحفظ

و العمل من الزميل الفاضل / عادل حنفى

مرفق  الملف 

جزاكم الله كل خير

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
   
    If ActiveWorkbook Is Nothing Then Exit Sub
    DefPath = ActiveWorkbook.Path
    If Len(DefPath) = 0 Then
        MsgBox "Plz Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"
        Exit Sub
    End If
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    strDate = Format(Now, " dd_mm_yyyy, hh.mm AMPM ")
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
 
    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
        ActiveWorkbook.SaveCopyAs FileNameXls
        newzip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        Kill FileNameXls
        MsgBox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
    Else
        MsgBox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"

    End If
End Sub
Private Sub newzip(sPath)
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub
 

ابوعلي.rar

[ياسر خليل أبو البراء]

أخي الكريم وعليكم السلام

يرجى وضع الأكواد بين أقواس الكود لتظهر بشكل منضبط

جرب الكود التالي

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object

    If ActiveWorkbook Is Nothing Then Exit Sub

    On Error Resume Next
        DefPath = ThisWorkbook.Path & "\مجلد النسخ الاحتياطية\"
        MkDir DefPath
    On Error GoTo 0

    If Len(DefPath) = 0 Then
        MsgBox "Please Save Activeworkbook Before Zipping" & Space(12), vbInformation, "Zipping"
        Exit Sub
    End If

    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd_mm_yyyy, hh.mm AMPM ")
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"

    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
        ActiveWorkbook.SaveCopyAs FileNameXls
        newzip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls
        
        On Error Resume Next
            Do Until oApp.Namespace(FileNameZip).items.Count = 1
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
        On Error GoTo 0
        
        Kill FileNameXls
        MsgBox "Completed Zipped : " & vbNewLine & FileNameZip, vbInformation, "Zipping"
    Else
        MsgBox "FileNameZip Or/And FileNameXls Exist", vbInformation, "Zipping"
    End If
End Sub

Private Sub newzip(sPath)
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

تقبل تحياتي

 

[ابوعلي الحبيب]

جزاك الله خير

 

 

ولكن مازل يحفظ في السي 

مكان الملف الاصل

وانا اريده ان يحفظ بالدي

اريده ان احدد مكان الحفظ في القرص من الكود 

 

 

جزاكم الله كل خير

[ياسر خليل أبو البراء]

الان, ابوعلي الحبيب said:

جزاك الله خير

 

 

ولكن مازل يحفظ في السي 

مكان الملف الاصل

وانا اريده ان يحفظ بالدي

اريده ان احدد مكان الحفظ في القرص من الكود 

 

 

جزاكم الله كل خير

قم بالتغيير في هذا السطر

DefPath = ThisWorkbook.Path & "\مجلد النسخ الاحتياطية\"

ضع المسار المطلوب بين أقواس تنصيص بهذا الشكل

defpath = "D:\مجلد النسخ الاحتياطية\"

تقبل تحياتي

[ابوعلي الحبيب]

 

 

جزاكم الله خيرا وبارك الله فيك استاذنا الكريم

[ياسر خليل أبو البراء]

وجزيت خيراً بمثل ما دعوت لي أخي الكريم

الحمد لله الذي بنعمته تتم الصالحات

تقبل تحياتي