Sauvegarder Classeur dans Dossier Compréssé

[MuscatMimi]

Bonjour a tout le forum

Le code ci dessous, copier sur ce Site, code issu de PascalXLD
Ce Code me créé bien un Dossier Compréssé,la OK

Ce que je désire faire, et je n'y arrive pas, c'est de Sauvegarder mon Fichier Excel dans ce dossier Compréssé

cela est-il réalisable en Vba

Voici le Code de création dossier compréssé

Sub ZipFichier()
    Dim oShell As Object, FSO As Object
    Dim I As Long
    Dim Fichier As String, MyBinary As String
    Dim LeZip As Variant
    Dim MyHex As Variant
    
    Fichier = "F:\Mes Documents Cat\Classeur2.xls"
    LeZip = "F:\Mes Documents Cat\Ma sauvegarde.zip"
     
    Set FSO = CreateObject("Scripting.FileSystemObject")
    MyHex = _
        Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
    
    For I = 0 To UBound(MyHex)
        MyBinary = MyBinary & Chr(MyHex(I))
    Next
    
    With FSO.CreateTextFile(LeZip, True)
        .Write MyBinary
       
        .Close
    End With

End Sub

merci beaucoup de votre aide
Cordialement

 

[MuscatMimi]

Re : Sauvegarder Classeur dans Dossier Compréssé

Petit Up
apparament ma demande est insolvable???

 

[Staple1600]

Re : Sauvegarder Classeur dans Dossier Compréssé

Bonsoir

apparemment ma demande est insolvable???

Non.


Tu as utilisé le moteur de recherche du forum ?

ou es-tu allé voir chez Ron ?

 

[MuscatMimi]

Re : Sauvegarder Classeur dans Dossier Compréssé

Bonjour Stapple
Merci pour ton info
Je suis allez voir sur le site de Ron
génial, c'est une mine d'or
J'ai trouvé mon bonheur

Voici le Code qui permet d'enregistrer le classeur actif dans un dossier compréssé

Sub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String

    DefPath = "F:\Mes Documents Cat\Test\"    '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and Zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
    
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
    
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameXls

        MsgBox "Your Backup is saved here: " & FileNameZip

    Else
        MsgBox "FileNameZip or/and FileNameXls exist"

    End If
End Sub

Bonne journée a tous