كود بفكرة جديدة

[وليد زقزوق]

علي غرار كود لعمل نسخة احتياطية

اريد كود لاخد نسخة من الملف وجعلة مضغوط winrar بمعني اصح هام جدا للحاجة اليه

[رجب جاويش]

السلام عليكم

هذا ملف من اعداد الأستاذ الكبير عادل حنفى

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

 

backup.zip

[احمد فضيله]

السلام عليكم و رحمة الله و بركاته
الاخ الفاضل الاستاذ / رجب جاويش

جزاك الله كل خير .. ملف ممتاز

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

[وليد زقزوق]

الاستاذ رجب جاويش ملف وكود رائع جدا

لكنة عند وضعة في ملفي لم يقم بنفس العمل داخل الملف المثال

[أبو محمد أشرف]

أرفق الملف وسيتم العمل عليه إن شاء الله

[عمر أبو صهيب]

أحسن الله إلى كل من يقوم على خدمة الأعضاء و يفيدهم و يضحي بوقته من أجل النفع

[رجب جاويش]

الأخ الفاضل والأستاذ المحترم / أحمد فضيله

جزاك الله كل خير على هذا المرور العطر والكلمات الطيبة

[رجب جاويش]

أخى الفاضل / وليد

تأكد من وضع الكود فى حدث الـ  thisworkbook

[وليد زقزوق]

مكانة مظبوط تماما ولكنة يتعارض مع كود اخر في حدث الملف

Private Sub Workbook_BeforeClose(Cancel As Boolean)

يوجد كودين بهذا الاسم

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

[رجب جاويش]

أخى الفاضل / وليد

أرسل الكود الثانى

أو أرفق الملف ربما يمكن دمج الكودين فى كود واحد

[أبو محمد عباس]

السلام عليكم ورحمة الله وبركاته

الاستاذ الحبيب رجب جاويش اعطاك الله سبحانه وتعالى الصحة والعافية

كود رائع وعمل اروع والشكر موصول للاستاذ الفاضل عادل حنفي جزاه الله خيرا

دمتم في رعاية الله وحفظه

[وليد زقزوق]

اخي رجب

تفضل

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets("main screen").Activate
Application.ScreenUpdating = False
For I = 2 To Sheets.Count
Sheets(I).Unprotect (1234)
Next
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_Open()
Sheets("MyDate").Range("E3:IT3").ClearContents
For I = 2 To Sheets.Count
Sheets("MyDate").Cells(3, I + 3) = Sheets(I).Name
Next
'UserForm1.Show
End Sub

[رجب جاويش]

أخى وليد

تم دمج الأكواد المطلوبة

وتكون بهذا الشكل

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Sheets("main screen").Activate
For I = 2 To Sheets.Count
Sheets(I).Unprotect (1234)
Next
     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-mmm-yy h-mm-ss")
    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 Workbook_Open()
Sheets("MyDate").Range("E3:IT3").ClearContents
For I = 2 To Sheets.Count
Sheets("MyDate").Cells(3, I + 3) = Sheets(I).Name
Next
'UserForm1.Show
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