تعديل كود نسخة احتياطية مضغوطة للاستاذ عادل حنفى

[abouelhassan]

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

الكود يعمل نسخة مضغوطة بجانب الملف عند كل غلق يعمل نسخة احتياطية

المطلوب

ان يسأل الكود هل تريد عمل نسخة احتياطية اذا جبنا نعم يعمل نسخة مضغوطة فى فولد اسمه باك اب فى البارتشن d 

واذا كررنا العملية يطلب منا هل تريد عمل نسخة احتياطية عند اخيار نعم يعمل نسخة احتياطية فوق القديمة وليس بجانبها بتاريخ جديد كما يعمل الان

واذا اجبنا لا لايعمل نسخة احتياطية والغرض هو عمل النسخة الاحتياطى مرة واحدة اخر اليوم عند عمل حفظ للملف وليس عند الغلق 

مع الشكر والتقدير

backup2007. 21-أبريل-20 20-43-14.zip

[محمد ايمن]

تفضل اخي الكريم

مع انني ضد فكرة حذف الملفات تلقائيا والسبب في بعض الاحيان تحتاج الى الرجوع لملف قديم للاطلاع على تعديل ما

ملاحظة هامة جدا :: الكود يحذف كل الملفات في المجلد D:\Backup

نسخة احتياطية مضغوطة.rar

[saad abed]

اخى محمد ايمن

انت مبدع 

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

اشكرك

[abouelhassan]

بس هناك مشكلة استاذنا الكود يمسح كل ما بداخل الفولدر

هل بالامكان ان يقوم بعمل النسخة الاحتياطية بفولدر داخل الفولدر بأسم الشهر ويطلب منا هل تريد

استبدال النسخة اذا كان نعم يستبدلها اما اذا كان لا يعمل نسخة خارج الفولدر  يعنى المسار يكون

فولدر d/backup/aprail

الكود هل تريد استبدال نسخة الباك اب يمسح النسخة التى بداخل فولدر الشهر لا تنسخ فى فولدر باك اب

مع خالص احترامى وتقديرى لشخص حضرتك الكريم

[محمد ايمن]

اخي الكريم

عليك دائما التفكير في كل الاحتمالات الممكنة حتى لو كانت نسبتها شبه معدومة

في فكرتك هناك ثغرة وهي سيئة جدا

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

هل لك ان تتخيل حجم الكارثة ؟؟

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

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

من وجهة نظري و حسب اغلب برامج المحاسبة لا يقوم البرنامج بحذف النسخة الاحتياطية ابدا (الحذف يتم يدويا)

 

[abouelhassan]

بارك الله فيك استاذنامحمد ايمن طيب هل يمكن أن تظهر لنا شاشة هل تريد النسخ الاحتياطى نعم يتم النسخ لا لأيام النسخ مع الشكر من كل قلبي

[محمد ايمن]

عذرا اخي الكريم لم افهم هذا السطر ( لا لأيام النسخ) يرجى التوضيح اكثر

[محمد ايمن]

الكود يظهر خيار نعم او لا !!!!

[abouelhassan]

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

لان حدث لى مشكلة عند حذف القديمة 

مشكور وبارك الله فيك

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXlsm
    Dim oApp As Object
 
ActiveWorkbook.Save
If MsgBox("åá ÊÑíÏ ÅäÔÇÁ äÓÎÉ ÇÍÊíÇØíÉ¿", vbInformation + vbMsgBoxRight + vbYesNo, "Zipping") = vbYes Then
 MakeSureDirectoryPathExists ("D:\BackUp\")
 
    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
    DefPath = "D:\BackUp\"
    
    Dim oFSO As FileSystemObject
    Dim oFolder As Folder
    Dim oFile As File

    Set oFSO = New FileSystemObject
    Set oFolder = oFSO.GetFolder(DefPath)
    For Each oFile In oFolder.Files
    oFile.Delete (True)
        'Debug.Print oFile.Name
    Next 'oFile

   


    
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXlsm = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xlsm"
 'On Error Resume Next
    If Dir(FileNameZip) = "" And Dir(FileNameXlsm) = "" Then
        ActiveWorkbook.SaveCopyAs FileNameXlsm
        newzip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXlsm
        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 FileNameXlsm
        MsgBox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
    Else
        MsgBox "FileNameZip or/and FileNameXlsm exist", vbInformation, "zipping"

    End If
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

كل الشكر والاحترام والتقدير