I. Introduction▲
Dans une entreprise, la configuration des postes de travail peut varier d’un service à l’autre, d’une filiale à l’autre ; dans ces conditions, il est délicat de programmer une application en VBA qui se base sur l’appel à un logiciel tiers, tels que 7-Zip ou WinZIP, pour compresser ou décompresser des fichiers au format ZIP(1), car rien ne vous assure qu’il sera installé chez tous les utilisateurs.
C’est encore plus vrai lorsque vous êtes programmeur indépendant et avez affaire à des clients qui ont chacun leur propre configuration logicielle.
La solution que je préconise est d’utiliser les ressources Windows, car elles vous assureront la compatibilité nécessaire.
En effet, depuis Windows XP, le système d’exploitation de Microsoft intègre des fonctionnalités qui permettent de compresser et décompresser des fichiers au format ZIP sans avoir besoin de recourir à un logiciel tiers. Alors, pourquoi s’en priver ?
En VBA, nous accéderons à ces ressources grâce à l’objet Namespace(2) et sa méthode CopyHere(3).
La FAQ du site « developpez.com » donne un exemple pour compresser le fichier « Fichier.xls » dans l’archive « Archive.Zip », du même dossier nommé « Dossier » :
- création d’un fichier vierge qui ne contient que la signature(4) (22 octets) d’un ZIP :
FileNumber = FreeFile
Open "C:\Dossier\Archive.Zip" For Output As #FileNumber
Print #FileNumber, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #FileNumber - compression automatique du fichier lors de sa copie dans cette archive. L’interpréteur de commande de Windows, en lisant la signature de l’archive, a deviné qu’il fallait le compresser :
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace("C:\Dossier\Archive.Zip").CopyHere ("C:\Dossier\Fichier.xls")
Et inversement pour décompresser cette archive ZIP dans le répertoire « Dossier » :
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace("C:\Dossier").CopyHere ShellApp.Namespace("C:\Dossier\Archive.Zip").Items
Ce procédé comporte deux particularités :
- le traitement de compression est asynchrone (l’exécution du code VBA se poursuit alors que le traitement de compression n’est pas terminé) ;
- lorsque la compression ou la décompression est trop longue, une boîte de dialogue de progression s’affiche permettant à l’utilisateur d’interrompre l’opération s’il le désire.
Or, un traitement asynchrone ou la possibilité que l’utilisateur interrompe le traitement peut perturber le bon déroulement d’une application.
C’est le cas par exemple lorsque vous devez joindre un fichier compressé à un message Outlook, ou inversement, décompresser un fichier pour en exploiter les données.
C’est pourquoi j’ai développé les fonctions, que vous trouverez dans les pages qui suivent, qui forcent un mode synchrone des traitements et détectent leur interruption.
Ces fonctions étant plus complexes que celles de l’exemple, les débutants en VBA acquerront le niveau nécessaire avec le tutoriel « Tome 1 - Des bases de la programmation à l'algorithme de classement rapide QuickRanking ».
Cette documentation a été réalisée avec Excel 2016 version 32 bits sous Windows 10.
II. Liste des fichiers contenus dans une archive au format ZIP avec « ZIP_InfoArchive »▲
Avant d’étudier les fonctions de compression puis de décompression au format ZIP, intéressons-nous à la fonction personnelle ZIP_InfoArchive qui mémorise des informations sur les fichiers contenus dans une archive ZIP et renvoie leur taille cumulée. Nous verrons plus loin que cette information nous permettra de nous assurer que tous les fichiers ont bien été compressés ou décompressés.
Quelques explications sur le code avant de découvrir cette fonction :
Une archive ZIP détient dans sa structure(5) des informations sur les fichiers qu’elle contient, informations qui peuvent être lues en utilisant l’objet NameSpace.
L’appel prend cette forme où « ArchiveZip » est le nom de l’archive ZIP :
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace(ArchiveZip).Items
La lecture des fichiers de l’archive se fait par une boucle sur les éléments de cet objet :
For Each Element In ShellApp.Namespace(ArchiveZip).Items …. Next Element
Element.Path : donne le chemin complet et le nom du fichier.
Element.Name : donne le nom du fichier sans son chemin.
Element.Size : donne la taille du fichier non compressé.
Element.ModifyDate : donne la date et l’heure de la dernière modification du fichier.
Element.Type : donne le type du fichier reconnu par son extension.
Remarque : Element.Path inclut l’adresse de l’archive ZIP. Par exemple, le fichier « Alice.xls » contenu dans l’archive « C:\MesArchives\MonFichier.Zip » sera renseigné : « C:\MesArchives\MonFichier.Zip\Alice.xls ». Il conviendra donc d’ôter l’adresse de l’archive pour avoir le chemin réel et le nom du fichier, soit dans cet exemple « \Alice.xls ».
Le même fichier situé dans le dossier nommé « Elèves » de l’archive devra être présenté par « \Elèves\Alice.xls » au lieu de « C:\MesArchives\MonFichier.Zip\Elèves\Alice.xls ».
L’archive pouvant contenir des sous-répertoires, la fonction est récursive pour les analyser tous.
La fonction ZIP_InfoArchive prend en arguments :
- ArchiveZip : l’adresse et le nom de l’archive ZIP ;
- Fichiers : un tableau qui sera alimenté (en base 1) des informations sur les fichiers ;
- TypeInfo : le type d’informations désiré. Soit l’une des valeurs suivantes :
- NomComplet = le chemin (réel) et le nom du fichier,
- NomCourt = le nom du fichier sans notion de chemin,
- Taille = la taille du fichier non compressé,
- DateModif = la date de modification (jour et heure),
- TypeFichier = le type du fichier (reconnu par son extension) ; - TailleChemin : une valeur utilisée pour la récursivité, qu’il faut laisser à 0 ou ne pas renseigner.
La fonction renvoie la taille cumulée en octets de tous les fichiers de l’archive une fois décompressés (ou 0 si aucun fichier).
L’énumération Enum_Zip_InfoArchive est déclarée en en-tête du module :
Enum Enum_Zip_InfoArchive
NomComplet
NomCourt
Taille
DateModif
TypeFichier
End Enum
------------------------------------------------------------------------------------------------------
Function ZIP_InfoArchive(ArchiveZip As Variant, Fichiers() As Variant, _
TypeInfo As Enum_Zip_InfoArchive, _
Optional TailleChemin As Integer = 0) As Long
'------------------------------------------------------------------------------------------------------
Dim ShellApp As Object, Element As Object
Static i As Long, TailleFichiers As Long
' Gestion des Erreurs :
On Error GoTo Gest_Err
' Initialisation au premier passage (mémorise la longueur du chemin ArchiveZip) :
If TailleChemin = 0 Then i = 0: TailleFichiers = 0: TailleChemin = Len(ArchiveZip) + 1
' Boucle sur le contenu de l'archive ZIP :
Set ShellApp = CreateObject("Shell.Application")
For Each Element In ShellApp.Namespace(ArchiveZip).items
' Si c'est un répertoire alors faire un appel récursif :
If Element.IsFolder = True Then
Call ZIP_InfoArchive(ArchiveZip & "\" & Element.Name, Fichiers(), TypeInfo, TailleChemin)
' Sinon c'est un fichier alors le mémoriser et augmenter la taille cumulée des fichiers :
Else
TailleFichiers = TailleFichiers + Element.Size
i = i + 1
ReDim Preserve Fichiers(1 To i)
Select Case TypeInfo
Case NomComplet: Fichiers(i) = Mid(Element.Path, TailleChemin)
Case NomCourt: Fichiers(i) = Element.Name
Case Taille: Fichiers(i) = Element.Size
Case DateModif: Fichiers(i) = Element.ModifyDate
Case TypeFichier: Fichiers(i) = Element.Type
End Select
End If
Next Element
' Renvoie la taille cumulée des fichiers :
ZIP_InfoArchive = TailleFichiers
' Gestion des erreurs :
Gest_Err:
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
Un exemple d’appel de cette fonction pour mémoriser dans le tableau « NomFichiers » le nom des fichiers de l’archive « MonFichier.zip » située dans le répertoire « MesArchives », et dans le tableau « TailleFichiers » la taille de chacun d’entre eux.
Puis, les fichiers sont affichés par la commande Debug.Print.
La fonction renvoie dans tous les cas la taille cumulée des fichiers, ici « i » :
------------------------------------------------------------------------------------------------------
Sub Test_ZIP_InfoArchive()
'------------------------------------------------------------------------------------------------------
Dim i As Long, ik As Long, NomFichiers() As Variant, TailleFichiers() As Variant
i = ZIP_InfoArchive("C:\MesArchives\MonFichier.zip", NomFichiers, NomComplet)
i = ZIP_InfoArchive("C:\MesArchives\MonFichier.zip", TailleFichiers, Taille)
' Affiche la taille cumulée des fichiers décompressés :
Debug.Print "Taille totale cumulée : " & i
' Si l'archive contient des fichiers :
If i > 0 Then
' Boucle pour afficher le nom des fichiers et leur taille :
For ik = 1 To UBound(NomFichiers)
Debug.Print NomFichiers(ik), TailleFichiers(ik)
Next ik
End If
End Sub
'------------------------------------------------------------------------------------------------------
Si l’archive ne contient aucun dossier (1) l’affichage des fichiers sera par exemple :
\Alice.xls 1777
\Bob.xls 1234
\Clément.xls 5643
Mais si l’archive a été compressée avec son dossier « Elèves » et un sous-dossier « Absences » (2) alors l’ordre d’affichage des fichiers sera différent, car le classement est alphabétique et inclut l’arborescence :
\Elèves\Absences\Bob.xls 1234
\Elèves\Absences\Clément.xls 5643
\Elèves\Alice.xls 1777
Tout dépend comment a été générée l’archive : par ajout de fichiers (1) ou par ajout d’un dossier (2).
III. Fonction de compression « ZIP_Compresser »▲
La compression de fichiers se fait avec la fonction ZIP_Compresser qui accepte les arguments suivants :
- ArchiveZip : l’adresse et le nom de l’archive ZIP à créer (si elle existe déjà, elle est remplacée) ;
- FichiersOuDossier : soit un ou des fichiers à compresser (adresse et noms), les jokers sont acceptés (1), soit un dossier entier à compresser en incluant ses sous-dossiers (2).
La fonction renvoie True si tout se passe bien ou False dans le cas contraire et renseigne alors les variables publiques déclarées en en-tête du module ZIP_ErrNumber et ZIP_ErrDescription avec respectivement le code de l’erreur Err.Number et sa description Err.Description.
Ces deux variables seront exploitées par le programmeur s’il souhaite afficher un message d’erreur ou gérer un fichier de suivi des événements (vous trouverez un exemple de gestion d’un log dans le fichier joint).
La fonction repose sur l’utilisation de l’objet NameSpace et de sa méthode CopyHere pour compresser la source dans l’archive avec les ressources Windows, comme vu dans l’introduction, mais désormais nous allons rendre la fonction synchrone, éviter autant que possible les annulations par l’utilisateur et contrôler la bonne exécution du traitement.
- Pour rendre le traitement synchrone : la compression étant asynchrone, le traitement boucle tant que la taille de l’archive évolue. Ce qui le rend ainsi synchrone.
- Pour contrer le problème de la boîte de dialogue de progression qui offre la possibilité à l’utilisateur d’interrompre le traitement : sachant que cette boîte ne s’affiche que lorsque le traitement de compression est long, généralement lors d’un traitement sur un réseau avec une connexion à faible débit, les données sources sont préalablement copiées dans un répertoire temporaire du disque dur de l’utilisateur et l’archive ZIP est générée elle aussi en local dans un répertoire temporaire.
Vous noterez que ces copies sont réalisées avec les méthodes CopyFolder et CopyFile (pour copier respectivement un dossier ou des fichiers) de l’objet FileSystemObject, car elles sont synchrones, n’affichent pas de boîte de progression et ne peuvent donc pas être annulées par l’utilisateur. - Pour contrôler la bonne exécution du traitement : l’archive ZIP n’est déplacée vers sa destination finale (ici aussi par l’objet FileSystemObject afin d’éviter toute annulation) qu’après avoir vérifié avec ZIP_InfoArchive que tous les fichiers y sont. Dans le cas contraire résultant d’une interruption, la fonction renverra False.
Quelques explications sur le code avant de vous le présenter :
La création d’un répertoire temporaire se fait avec l’instruction MkDir et en argument le nom du répertoire de travail par défaut donné par la propriété Application.DefaultFilePath, suivi du nom de son choix et d’un numéro composé de la date et de l’heure pour le rendre unique.
L’archive ZIP vierge est générée par la fonction CreateZipHeader comme vu dans l’introduction.
La compression gère deux cas :
- soit la source est un répertoire (qu’il faudra compresser avec ses sous-répertoires) nous utiliserons CopyHere SourceItem ;
- soit la source est un fichier ou plusieurs fichiers puisque les jokers sont acceptés, nous utiliserons CopyHere SourceItem.items.
Mais dans les deux cas, la taille d’origine des fichiers est calculée par la fonction FilesSizeInFolders (qui analyse aussi les éventuels sous-répertoires).
Pour suivre l’évolution de la taille de l’archive et boucler tant qu’elle évolue, nous utilisons la méthode GetFile de l’objet FileSystemObject initialisée ainsi :
Set ObjFSO = CreateObject("Scripting.FileSystemObject").GetFile((ArchiveZip))
La taille est renvoyée par ObjFSO.Size.
Lorsque la compression est terminée ou interrompue, la taille de l’archive n’évolue plus et l’on sort de la boucle.
La taille des fichiers de l’archive (obtenue par la fonctions ZIP_InfoArchive) est comparée avec celle des fichiers sources.
Si elle est égale, c’est que le traitement s’est déroulé correctement et la fonction renvoie True, puis l’archive est déplacée dans son répertoire de destination ; dans le cas contraire, elle renvoie False.
L’archive est déplacée par une fonction personnelle :
MoveFile(SourcePath, SourceFileName, DestPath, DestFileName).
Le fichier destination « DestFileName » est supprimé s’il existait déjà.
Pour cela, nous n’utilisons pas l’instruction Kill du VBA car elle n’est pas capable de supprimer un fichier en lecture seule ou masqué.
Nous lui préférons donc une fonction personnelle KillFile(FullFileName) qui efface les attributs (lecture seule, masqué) du fichier avant de le supprimer.
Enfin, les dossiers temporaires peuvent être supprimés avec la fonction KillAllFolders(ByVal FolderName).
Le code de la fonction :
------------------------------------------------------------------------------------------------------
Public Function ZIP_Compresser(ByVal ArchiveZip As Variant, _
ByVal FichiersOuDossier As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
Dim ShellApp As Object, Cible As Object, SourceItem As Object, ObjFSO As Object, ObjFile As Object
Dim ObjZIP As Object
Dim TailleFichier As Long, TailleDecompresse As Long, lk As Long
Dim AncienCancelkey As Long, AncienDisplay As Boolean, i As Integer
Dim ZipPathTps As String, FilesPathTps As String, FolderPathTps As String, ArchiveTps As Variant
Dim DestDossier As String
Dim T() As Variant
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Empêche l'utilisateur d'interrompre le traitement avec Echap et active la barre d'état :
AncienCancelkey = Application.EnableCancelKey
Application.EnableCancelKey = xlDisabled
AncienDisplay = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "ZIP_Compresser - Création de l'archive " & ArchiveZip
Application.Cursor = xlWait
DoEvents
' Si l'archive n'est pas renseignée, alors génère une erreur :
If ArchiveZip = "" Then Err.Raise vbObjectError, , "L'archive de destination doit être renseignée."
' Si l'archive n'a pas l'extension ZIP alors l'ajoute :
If UCase(Right(ArchiveZip, 4)) <> ".ZIP" Then ArchiveZip = ArchiveZip & ".zip"
' Si le dossier de destination n'est pas présent alors génère une erreur :
DestDossier = Left(ArchiveZip, InStrRev(ArchiveZip, "\"))
If IsFolderExists(DestDossier) = False Then _
Err.Raise vbObjectError, , "Le dossier de destination " & DestDossier & " n'est pas présent."
' Création d'un répertoire temporaire où seront copiés les fichiers concernés :
FolderPathTps = Application.DefaultFilePath & "\TPS~" & Format(Date, "0") & Format(Timer, "0")
MkDir FolderPathTps
FilesPathTps = FolderPathTps
' Création d'un répertoire et d'un ZIP temporaire :
ZipPathTps = Application.DefaultFilePath & "\ZIP~" & Format(Date, "0") & Format(Timer, "0")
MkDir ZipPathTps
ArchiveTps = ZipPathTps & "\ZIP.ZIP"
If CreateZipHeader(ArchiveTps) = False Then _
Err.Raise vbObjectError, , "Echec de création du ZIP dans le répertoire temporaire " & ArchiveTps & "."
' Si la source est un répertoire :
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If IsFolderExists(FichiersOuDossier) = True Then
' Supprime le "\" final dans le nom du répertoire :
If Right(FichiersOuDossier, 1) = "\" Then FichiersOuDossier = Mid(FichiersOuDossier, 1, Len(FichiersOuDossier) - 1)
' Ajoute un répertoire au répertoire temporaire :
If InStrRev(FichiersOuDossier, "\") > 0 Then
FilesPathTps = FilesPathTps & Mid(FichiersOuDossier, InStrRev(FichiersOuDossier, "\"))
End If
' Copie le répertoire source dans le répertoire temporaire (synchrone) :
CreateObject("Scripting.FileSystemObject").CopyFolder FichiersOuDossier, FilesPathTps, True
' Vérifie qu'il y a bien quelque chose à compresser :
If FilesSizeInFolders(FilesPathTps) = 0 Then _
Err.Raise vbObjectError, , "Aucun fichier à compresser dans " & FichiersOuDossier
' Initialise la source et la destination :
Set ShellApp = CreateObject("Shell.Application")
Set SourceItem = ShellApp.Namespace((FilesPathTps))
Set Cible = ShellApp.Namespace((ArchiveTps))
' Compresse le répertoire et ses sous-répertoires (y compris les masqués) dans l'archive ZIP (asynchrone) :
Cible.CopyHere SourceItem
' Calcule la taille des fichiers décompressés qu'il faudra retrouver dans le ZIP :
TailleDecompresse = FilesSizeInFolders(FichiersOuDossier)
' Pointe sur l'archive ZIP pour suivre l'évolution de sa taille :
Set ObjZIP = CreateObject("Scripting.FileSystemObject").GetFile((ArchiveTps))
' Boucle d'attente tant que la taille de l'archive ZIP évolue :
Do
TailleFichier = ObjZIP.Size
lk = Timer: While lk + 3 > Timer: DoEvents: Wend
Loop While TailleFichier <> ObjZIP.Size
' Si la source est un jeu de fichiers :
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
' Contrôle que la source existe :
If IsFileExists(FichiersOuDossier) = False And IsFolderExists(FichiersOuDossier) = False Then _
Err.Raise vbObjectError, , "La source " & FichiersOuDossier & " n'est pas disponible."
' Copie les fichiers sources dans le répertoire temporaire (synchrone) :
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
ObjFSO.CopyFile FichiersOuDossier, FilesPathTps & "\"
' Vérifie qu'il y a bien quelque chose à compresser :
If FilesSizeInFolders(FilesPathTps) = 0 Then _
Err.Raise vbObjectError, , "Aucun fichier à compresser dans " & FichiersOuDossier
' Pointe sur l'archive ZIP pour suivre l'évolution de sa taille :
Set ObjZIP = CreateObject("Scripting.FileSystemObject").GetFile((ArchiveTps))
' Compresse les fichiers sauf ceux masqués dans l'archive ZIP (asynchrone) :
Set ShellApp = CreateObject("Shell.Application")
Set SourceItem = ShellApp.Namespace((FilesPathTps))
Set Cible = ShellApp.Namespace((ArchiveTps))
Cible.CopyHere SourceItem.items
' Attend la fin de la copie :
Do
TailleFichier = ObjZIP.Size
lk = Timer: While lk + 2 > Timer: DoEvents: Wend
Loop While TailleFichier <> ObjZIP.Size
' Compresse un à un les fichiers masqués dans l'archive ZIP (asynchrone) :
For Each ObjFile In ObjFSO.GetFolder(FilesPathTps).Files
If (ObjFile.Attributes And 2) <> 0 Then
Application.StatusBar = "ZIP_Compresser - Compression du fichier masqué " & ObjFile.Name
DoEvents
ShellApp.Namespace(ArchiveTps).CopyHere ObjFile.Path
Do
TailleFichier = ObjZIP.Size
lk = Timer: While lk + 2 > Timer: DoEvents: Wend
Loop While TailleFichier <> ObjZIP.Size
End If
Next ObjFile
' Calcule la taille des fichiers décompressés qu'il faudra retrouver dans le ZIP :
TailleDecompresse = FilesSizeInFolders(FilesPathTps)
End If
' Si la taille des fichiers sources décompressés est différente de la taille des fichiers
' décompressés dans l'archive ZIP c'est qu'il y a eu interruption :
If TailleDecompresse <> ZIP_InfoArchive(ArchiveTps, T, NomComplet) Then _
Err.Raise vbObjectError, , "Le traitement de compression de " & ArchiveZip & " a été interrompu."
' Tout s'est bien passé et l'on peut déplacer le ZIP dans sa destination (synchrone) :
Application.StatusBar = "ZIP_Compresser - Copie de " & ArchiveZip
DoEvents
i = InStrRev(ArchiveZip, "\")
ZIP_Compresser = MoveFile(ZipPathTps, "ZIP.ZIP", Left(ArchiveZip, i), Mid(ArchiveZip, i + 1))
' Gestion des erreurs (renseigne ZIP_ErrNumber et ZIP_ErrDescription en cas d'erreur et renvoie False) :
Gest_Err:
ZIP_ErrNumber = Err.Number: ZIP_ErrDescription = Err.Description
Err.Clear
' Efface les répertoires temporaires :
KillAllFolders FolderPathTps
KillAllFolders ZipPathTps
' Restaure la barre d'état et l'interruption du traitement :
Application.StatusBar = False
Application.DisplayStatusBar = AncienDisplay
Application.EnableCancelKey = AncienCancelkey
Application.Cursor = xlDefault
Function
'------------------------------------------------------------------------------------------------------Exemples d’appels de cette fonction pour compresser des fichiers du répertoire « Dossier » dans l’archive « MonFichier.zip » qui sera créée dans le répertoire « Archive » :
- Pour compresser le ficher « Test.xls » : ZIP_Compresser("C:\Archive\MonFichier.zip", "C:\Dossier\Test.xls")
- Pour compresser tous les fichiers « .xlsm » : ZIP_Compresser("C:\Archive\MonFichier.zip", "C:\Dossier\*.xlsm")
- Pour compresser tous les fichiers du dossier, mais pas ses sous-répertoires : ZIP_Compresser("C:\Archive\MonFichier.zip", "C:\Dossier\*.*")
- Pour compresser tous les fichiers du dossier et ses sous-répertoires : ZIP_Compresser("C:\Archive\MonFichier.zip", "C:\Dossier")
Le cas particulier des fichiers masqués :
lorsque tout le dossier et ses sous-dossiers sont compressés (le quatrième appel dans les exemples ci-dessus) la méthode CopyHere SourceItem inclut bien les fichiers masqués, mais curieusement, lorsque les fichiers sont ajoutés par lots (premier, deuxième et troisième exemples ci-dessus) la méthode CopyHere SourceItem.items ne traite plus les fichiers masqués. Il faut alors les ajouter un à un avec la méthode CopyHere File.
Les autres fonctions appelées sont écrites avec des termes anglophones… alors que cette documentation est destinée à un public francophone.
Je suis bien conscient que cela peut surprendre certains d’entre vous.
Avant de me le reprocher, je vous invite à consulter les commentaires sur ce billet où l’essentiel est dit.
------------------------------------------------------------------------------------------------------
Private Function CreateZipHeader(FileName As Variant) As Boolean
'----------------------------------------------------------------
' Création d'un fichier vierge avec la signature d'un ZIP (22 caractères).
' Signature of the EOCD : &H06054b50
' Renvoie : VRAI si tout s'est bien passé.
' voir aussi : https://exceloffthegrid.com/vba-cod-to-zip-unzip/
'------------------------------------------------------------------------------------------------------
Dim FileNumber As Long
' Gestion des erreurs :
On Error GoTo Gest_Err
FileNumber = FreeFile
Open FileName For Output As #FileNumber
Print #FileNumber, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #FileNumber
CreateZipHeader = True
Gest_Err:
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function FilesSizeInFolders(FolderName As Variant) As Long
'------------------------------------------------------------------------------------------------------
' Renvoie la taille des fichiers du répertoire passé en argument et de ses sous-répertoires,
' y compris les fichiers masqués (par exemple c'est le cas des fichiers temporaires qui commencent par ~$).
' FolderName : le répertoire.
'------------------------------------------------------------------------------------------------------
FilesSizeInFolders = CreateObject("Scripting.FileSystemObject").GetFolder(FolderName).Size
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function KillFile(FullFileName As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
' Supprime le fichier passé en argument même s'il est en lecture seule ou masqué.
' FullFileName : contient le chemin et le nom du fichier (les jokers ne sont pas acceptés).
' Renvoie : VRAI si tout s'est bien passé ou FAUX dans le cas contraire.
' Remarque : Dir() ne reconnaît pas les fichiers masqués,
' Kill ne supprime pas les fichiers en lecture seule ou masqués.
' Voir aussi : https://vb.developpez.com/faq/vbs?page=Acces-aux-Fichiers
'------------------------------------------------------------------------------------------------------
Dim ObjFSO As Object, ObjFile As Object
' Gestion des erreurs :
On Error GoTo Gest_Err
' Création d'un objet FileSystemObject :
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
' Si le fichier existe :
If ObjFSO.FileExists(FullFileName) = True Then
Set ObjFile = ObjFSO.GetFile(FullFileName) ' Pointe sur le fichier.
ObjFile.Attributes = 0 ' Efface les attributs.
ObjFSO.DeleteFile FullFileName, True ' Supprime le fichier
End If
' Renvoie VRAI si tout s'est bien passé :
KillFile = True
' Gestion des erreurs :
Gest_Err:
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function IsFolderExists(FolderName As Variant)
'------------------------------------------------------------------------------------------------------
' Renvoie VRAI si le répertoire passé en argument dans FolderName existe.
' FolderName : le répertoire.
'------------------------------------------------------------------------------------------------------
IsFolderExists = CreateObject("Scripting.FileSystemObject").Folderexists(FolderName)
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Public Function IsFileExists(FileName As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
' Vérifie si un fichier existe même s'il est masqué.
' FileName : contient le chemin et le nom du fichier, les jokers sont acceptés.
' Renvoie : VRAI si tout s'est bien passé ou FAUX dans le cas contraire.
' Remarque : Dir() ne reconnaît pas les fichiers masqués
'------------------------------------------------------------------------------------------------------
If Dir(FileName, vbNormal + vbHidden + vbReadOnly) <> "" Then IsFileExists = True
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Sub KillAllFilesInFolder(FolderName As Variant, SubFolder As Boolean)
'------------------------------------------------------------------------------------------------------
' Supprime tous les fichiers d'un répertoire et (si demandé) des sous-répertoires.
' FolderName : le nom du répertoire.
' SubFolder : Si VRAI, alors supprime les fichiers des sous-répertoires.
'------------------------------------------------------------------------------------------------------
Dim ObjFSO As Object, ObjDossier As Object, ObjSousRep As Object, ObjFile As Object
Dim SousRep As Object
' Création d'un objet FileSystemObject:
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
' Si le répertoire existe :
If ObjFSO.FolderExists(FolderName) = True Then
Set ObjDossier = ObjFSO.GetFolder(FolderName) ' Objet Dossier.
Set ObjSousRep = ObjDossier.SubFolders ' Objet Sous-répertoire.
' Boucle sur les fichiers du répertoire :
For Each ObjFile In ObjDossier.Files
KillFile ObjFile.Path
Next ObjFile
' Boucle sur les sous-répertoires :
If SubFolder = True Then
For Each SousRep In ObjSousRep
Call KillAllFilesInFolder(SousRep.Path, SubFolder)
Next SousRep
End If
End If
End Sub
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function KillAllFolders(ByVal FolderName As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
' Supprime le répertoire passé en argument et tous ses sous-répertoires.
' FolderName : répertoire racine sans le "\" final.
' Attention : le répertoire ne doit pas être sélectionné dans l'explorateur Windows car cela
' provoque une erreur : 70 - Permission refusée.
' Renvoie : True si tout s'est bien passé ou False en cas d'erreur.
'------------------------------------------------------------------------------------------------------
On Error Resume Next
Err.Clear
If CreateObject("scripting.filesystemobject").Folderexists(FolderName) = True Then
' Supprime le "\" final :
If Right(FolderName, 1) = "\" Then FolderName = Left(FolderName, Len(FolderName) - 1)
' Supprime le dossier et ses sous-dossiers (même s'il y a des fichiers dedans) :
CreateObject("scripting.filesystemobject").DeleteFolder FolderName, True
DoEvents
' Ferme l'explorateur si une erreur 70 est générée puis relance la suppression :
If Err.Number = 70 Then
Err.Clear
Fermer_Explorer
CreateObject("scripting.filesystemobject").DeleteFolder FolderName, True
End If
End If
If Err.Number = 0 Then KillAllFolders = True
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function SubFolderName(ByVal FolderName As Variant) As String
'------------------------------------------------------------------------------------------------------
' Renvoie le premier sous-répertoire trouvé au répertoire passé dans l’argument FolderName.
'------------------------------------------------------------------------------------------------------
Dim SousRep As Object
On Error Resume Next
For Each SousRep In CreateObject("Scripting.FileSystemObject").GetFolder(FolderName).SubFolders
SubFolderName = SousRep.Name
Exit For
Next SousRep
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Private Function MoveFile(ByVal SourcePath As Variant, ByVal SourceFileName As Variant, _
ByVal DestPath As Variant, ByVal DestFileName As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
' Déplace un fichier d'un dossier à un autre. Renvoie : VRAI si tout s'est bien passé.
' SourcePath : répertoire source.
' SourceFileName : nom du fichier source.
' DestPath : répertoire de destination où sera copiée la source.
' DestFileName : nom du fichier généré.
'------------------------------------------------------------------------------------------------------
Dim ObjFSO, i As Integer, Dossier As String, T As Variant
Err.Clear
On Error GoTo Gest_Err
' Ajoute le "\" final aux répertoires indiqués :
If Right(SourcePath, 1) <> "\" Then SourcePath = SourcePath & "\"
If Right(DestPath, 1) <> "\" Then DestPath = DestPath & "\"
' Supprime le "\" en début du nom du fichier source et destination :
If Left(SourceFileName, 1) = "\" Then SourceFileName = Mid(SourceFileName, 2)
If Left(DestFileName, 1) = "\" Then DestFileName = Mid(DestFileName, 2)
' Crée l'arborescence si nécessaire :
T = Split(DestFileName, "\")
If UBound(T) > 0 Then
Dossier = DestPath
For i = 0 To UBound(T) - 1
Dossier = Dossier & T(i) & "\"
If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier
Next i
End If
' Supprime l'ancien fichier avant de déplacer le fichier
If KillFile(DestPath & DestFileName) = True Then
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
ObjFSO.MoveFile Source:=SourcePath & SourceFileName, Destination:=DestPath & DestFileName
MoveFile = True
End If
' Gestion des erreurs :
Gest_Err:
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
IV. Fonction de décompression « ZIP_Decompresser »▲
La décompression d’une archive ZIP se fait avec la fonction ZIP_Decompresser qui accepte les arguments suivants :
- ArchiveZip : l’adresse et le nom de l’archive ZIP ;
- DestDossier : le répertoire de destination des fichiers décompressés.
La décompression utilise les mêmes ressources que la compression, c’est-à-dire l’objet NameSpace et sa méthode CopyHere et d’autres fonctions personnelles annexes, comme vu au chapitre précédent avec ZIP_Compresser nous n’y reviendrons donc pas ici.
La décompression se fait dans un dossier temporaire renseigné dans la variable « ZipPathTps » :
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace(ZipPathTps).CopyHere ShellApp.Namespace(ArchiveZip).Items
Si le fichier est trop long à décompresser, une boîte de dialogue système s'affiche et l'utilisateur peut annuler la décompression, mais le traitement reste synchrone (contrairement à la compression).
Après analyse, si la taille des fichiers du dossier temporaire correspond à la taille indiquée dans l’archive c’est que tout s’est bien passé, la fonction renvoie alors True et les fichiers sont déplacés dans leur dossier de destination. Dans le cas contraire, elle renvoie False et renseigne alors les variables publiques ZIP_ErrNumber et ZIP_ErrDescription avec respectivement le code de l’erreur Err.Number et sa description Err.Description.
Enfin, le dossier temporaire est supprimé.
------------------------------------------------------------------------------------------------------
Public Function ZIP_Decompresser(ByVal ArchiveZip As Variant, ByVal DestDossier As String) As Boolean
'------------------------------------------------------------------------------------------------------
Dim ShellApp As Object, Escape As Long, Display As Boolean, i As Long
Dim TailleOrigine As Long, ZipPathTps As Variant
Dim SourceItem As Object, Cible As Object
Dim T() As Variant
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Empêche l'utilisateur d'interrompre le traitement avec Echap et active la barre d'état :
Escape = Application.EnableCancelKey
Application.EnableCancelKey = xlDisabled
Display = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "ZIP_Decompresser - " & ArchiveZip
Application.Cursor = xlWait
DoEvents
' Lit les archives dans le zip pour connaitre la taille totale d'origine à décompresser :
TailleOrigine = ZIP_InfoArchive(ArchiveZip, T, NomComplet)
If TailleOrigine = 0 Then Err.Raise vbObjectError, , ArchiveZip & " n'est pas reconnu comme archive ZIP."
' Ajoute un "\" au répertoire destination pour tester sa présence.
' Si le répertoire destination n'est pas présent alors génère une erreur :
If Right(DestDossier, 1) <> "\" Then DestDossier = DestDossier & "\"
If IsFolderExists(DestDossier) = False Then Err.Raise vbObjectError, , "Le répertoire " & DestDossier & " n'est pas présent."
' Supprime le dernier "\" du répertoire destination :
DestDossier = Left(DestDossier, Len(DestDossier) - 1)
' Crée un objet Shell :
Set ShellApp = CreateObject("Shell.Application")
' Crée un objet sur la source :
Set SourceItem = ShellApp.Namespace((ArchiveZip))
' Emet un message d'erreur si la source n'est pas correcte :
If SourceItem Is Nothing Then Err.Raise vbObjectError, , ArchiveZip & " n'est pas une source correcte."
' Crée un répertoire temporaire où seront décompressés les fichiers :
ZipPathTps = Application.DefaultFilePath & "\ZIP~" & Format(Date, "0") & Format(Timer, "0")
MkDir ZipPathTps
' Crée un objet sur la cible où décompresser :
Set Cible = ShellApp.Namespace((ZipPathTps))
' Décompresse les fichiers et répertoires depuis le ZIP dans le répertoire temporaire :
Cible.CopyHere SourceItem.items
' Si tous les fichiers de l'archive sont bien décompressés alors les déplace dans la destination :
If FilesSizeInFolders(ZipPathTps) = TailleOrigine Then
' S'il faut copier un dossier avec ses sous-dossiers alors supprime ceux existants :
If SubFolderName(ZipPathTps) <> "" Then
If KillAllFolders(DestDossier & "\" & SubFolderName(ZipPathTps)) = False Then _
Err.Raise vbObjectError, , "Le dossier " & DestDossier & "\" & SubFolderName(ZipPathTps) _
& " ne peut pas être supprimé."
End If
' Supprime dans la destination les fichiers existants :
Dim ObjFSO, ObjDossier, ObjFile
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjDossier = ObjFSO.GetFolder(ZipPathTps)
For Each ObjFile In ObjDossier.Files
KillFile DestDossier & "\" & ObjFile.Name
Next ObjFile
' Copie le dossier temporaire vers la destination :
ObjFSO.CopyFolder ZipPathTps, DestDossier, True
' Si pas d'erreur renvoie Vrai :
ZIP_Decompresser = True
End If
' Gestion des erreurs (renseigne ZIP_ErrNumber et ZIP_ErrDescription en cas d'erreur et renvoie False) :
Gest_Err:
ZIP_ErrNumber = Err.Number: ZIP_ErrDescription = Err.Description
Err.Clear
' Efface le répertoire temporaire :
KillAllFolders ZipPathTps
' Restaure l'interruption du traitement et la barre d'état :
Application.EnableCancelKey = Escape
Application.StatusBar = False
Application.DisplayStatusBar = Display
Application.Cursor = xlDefault
End Function
'------------------------------------------------------------------------------------------------------
Exemple d’appel de cette fonction pour décompresser les données de l’archive « MonFichier.zip » dans le répertoire « Dossier » :
ZIP_Decompresser("C:\Archive\MonFichier.zip", "C:\Dossier\")
Si l’archive ZIP contient des répertoires, ceux-ci seront créés automatiquement dans le dossier de destination en remplacement des éventuels dossiers existants.
Mais attention, le dossier de destination ne doit pas être sélectionné dans l'explorateur Windows, car cela provoque une erreur lors de la tentative de sa suppression pour son remplacement : 70 - Permission refusée.
Dans ce cas, la solution que j’ai retenue est de fermer l’explorateur en utilisant les API suivantes déclarées en en-tête du module :
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Et la fonction personnelle :
------------------------------------------------------------------------------------------------------
Private Sub Fermer_Explorer()
'------------------------------------------------------------------------------------------------------
Dim Hdc As LongPtr, T As Long
Do
Hdc = FindWindow("CabinetWClass", vbNullString)
Call SendMessage(Hdc, &H10, 0, 0)
DoEvents
Loop While Hdc <> 0
T = Timer: While T + 2 > Timer: DoEvents: Wend
End Sub
'------------------------------------------------------------------------------------------------------
V. Fonction d’extraction « ZIP_Extraire »▲
La fonction ZIP_Extraire permet de ne décompresser qu’une partie des fichiers de l’archive, contrairement à la fonction précédente ZIP_Decompresser qui décompresse tous les fichiers de l’archive.
Mais l’extraction ne reconstitue pas les éventuels répertoires et sous-répertoires de l’archive, les fichiers sont tous décompressés dans le répertoire de destination indiqué.
Cette fonction accepte les arguments suivants :
- ArchiveZip : l’adresse et le nom de l’archive ZIP ;
- FichiersAExtraire : le nom du ou des fichiers à extraire, les jokers sont admis pour sélectionner les fichiers concernés, le chemin des fichiers dans l’archive doit être mentionné (voir les exemples ci-dessous) ;
- DestDossier : le répertoire de destination.
La fonction renvoie True si tout se passe bien ou False dans le cas contraire et renseigne alors les variables publiques ZIP_ErrNumber et ZIP_ErrDescription avec respectivement le code de l’erreur Err.Number et sa description Err.Description.
Les fichiers à extraire sont sélectionnés par l’argument « FichiersAExtraire », qui offre plusieurs possibilités, grâce aux jokers et parce que le chemin des fichiers de l’archive est pris en compte.
Voir la fonction ZIP_InfoArchive pour bien comprendre cette notion.
Exemples d’appels de cette fonction pour extraire des fichiers de l’archive « MonFichier.zip » dans le répertoire « Dossier ». Deux cas sont possibles :
- l’archive ZIP ne contient aucun répertoire.
- Pour extraire le fichier « Test.xlsx » de l’archive : ZIP_Extraire("C:\Archive\MonFichier.zip", "Test.xlsx", "C:\Dossier\")
- Pour extraire tous les fichiers « .xlsx » : ZIP_Extraire("C:\Archive\MonFichier.zip", "*.xlsx", "C:\Dossier\") - l’archive contient un répertoire racine nommé « Toto » et des sous-répertoires.
- Pour extraire le fichier « Test.xlsx » de la racine de l’archive : ZIP_Extraire("C:\Archive\MonFichier.zip", "\Toto\Test.xlsx", "C:\Dossier\")
- Pour extraire tous les fichiers « .xlsx » de la racine et des sous-répertoires : ZIP_Extraire("C:\Archive\MonFichier.zip", "*.xlsx", "C:\Dossier\")
- Pour extraire tous les fichiers « .xlsx » situés dans le répertoire « A » et dans ses sous-répertoires : ZIP_Extraire("C:\Archive\MonFichier.zip", "\Toto\A\*.xlsx", "C:\Dossier\")
Remarques :
- si plusieurs fichiers de différents répertoires de l’archive ont le même nom, seul le premier fichier trouvé est décompressé. Voir la fonction ZIP_InfoArchive pour bien comprendre leur ordre de traitement qui est alphabétique en incluant les dossiers dans le classement ;
- si l’argument « FichiersAExtraire » est renseigné sans indication de dossier (par "*", "\" ou "?"), la barre oblique est ajoutée automatiquement. Par exemple avec « Test.xlsx » la sélection ne trouverait aucun fichier, c’est pourquoi elle est corrigée en « \Test.xlsx ».
------------------------------------------------------------------------------------------------------
Public Function ZIP_Extraire(ByVal ArchiveZip As Variant, _
ByVal FichiersAExtraire As String, _
ByVal DestDossier As String) As Boolean
'------------------------------------------------------------------------------------------------------
Dim ShellApp As Object, SourceItem As Object, Cible As Object
Dim TpsFilePath As Variant, TailleFichier As Long, lk As Long
Dim AncienCancelkey As Long, AncienDisplay As Boolean
Dim ObjFSO As Object, ObjFile As Object, ObjDossier As Object
Dim TComplet() As Variant, Ttaille() As Variant, TCourt() As Variant, i As Long
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Empêche l'utilisateur d'interrompre le traitement avec Echap et active la barre d'état :
AncienCancelkey = Application.EnableCancelKey
Application.EnableCancelKey = xlDisabled
AncienDisplay = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.Cursor = xlWait
' Si le dossier de destination n'est pas présent alors génère une erreur :
If IsFolderExists(DestDossier) = False Then _
Err.Raise vbObjectError, , "Le dossier de destination " & DestDossier & " n'est pas présent."
' Lecture des fichiers de l'archive :
Call ZIP_InfoArchive(ArchiveZip, TComplet, NomComplet)
Call ZIP_InfoArchive(ArchiveZip, TCourt, NomCourt)
i = ZIP_InfoArchive(ArchiveZip, Ttaille, Taille)
If i = 0 Then Err.Raise vbObjectError, , "L'archive " & ArchiveZip & " n'est pas disponible."
' Création d'un répertoire temporaire où seront copiés les fichiers concernés :
TpsFilePath = Application.DefaultFilePath & "\Ext~" & Format(Date, "0") & Format(Timer, "0")
MkDir TpsFilePath
' Création d'un objet Shell :
Set ShellApp = CreateObject("Shell.Application")
' Création d'un objet sur la cible où décompresser :
Set Cible = ShellApp.Namespace((TpsFilePath))
' Traitements :
Application.StatusBar = "ZIP_Extraire - Extraction de " & FichiersAExtraire
DoEvents
' Correction de FichiersAExtraire s'il ne commence pas par "\", "?" ou "*" :
If Left(FichiersAExtraire, 1) <> "\" And Left(FichiersAExtraire, 1) <> "?" And Left(FichiersAExtraire, 1) <> "*" Then
FichiersAExtraire = "\" & FichiersAExtraire
End If
' Boucle sur les fichiers de l'archive :
For i = 1 To UBound(TComplet)
' Si le fichier est à extraire alors le déplace dans le répertoire temporaire:
If UCase(TComplet(i)) Like UCase(FichiersAExtraire) Then
' Seulement s'il n'existe pas déjà dans le répertoire temporaire:
If IsFileExists(TpsFilePath & "\" & TCourt(i)) = False Then
' Calcule la future taille totale théorique du répertoire temporaire:
TailleFichier = TailleFichier + Ttaille(i)
' Décompresse le fichier:
Cible.CopyHere (ArchiveZip & TComplet(i))
' Si la taille du répertoire n'est pas celle attendue c'est que le traitement a été annulé:
If FilesSizeInFolders(TpsFilePath) <> TailleFichier Then _
Err.Raise vbObjectError, , "Extraction de " & TComplet(i) & " annulée."
End If
End If
Next i
' Boucle sur ces fichiers pour supprimer ceux de la destination :
If Right(DestDossier, 1) <> "\" Then DestDossier = DestDossier & "\"
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjDossier = ObjFSO.GetFolder(TpsFilePath)
For Each ObjFile In ObjDossier.Files
KillFile DestDossier & ObjFile.Name
Next ObjFile
' Copie les fichiers dans la destination :
ObjFSO.CopyFile TpsFilePath & "\*.*", DestDossier
ZIP_Extraire = True
' Gestion des erreurs (renseigne ZIP_ErrNumber et ZIP_ErrDescription en cas d'erreur et renvoie False) :
Gest_Err:
ZIP_ErrNumber = Err.Number: ZIP_ErrDescription = Err.Description
Err.Clear
' Efface le répertoire temporaire :
KillAllFolders TpsFilePath
' Restaure l'interruption du traitement et la barre d'état :
Application.EnableCancelKey = AncienCancelkey
Application.StatusBar = False
Application.DisplayStatusBar = AncienDisplay
Application.Cursor = xlDefault
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
VI. Fonction d’ajout « ZIP_Ajouter »▲
Dans une archive ZIP existante qui ne contient pas de dossier, un ou plusieurs fichiers peuvent y être ajoutés avec la fonction ZIP_Ajouter qui accepte les arguments suivants :
- ArchiveZip : l’adresse et le nom de l’archive ZIP concernée ;
- FichiersAAjouter : le nom du fichier ou des fichiers à ajouter (chemin + nom), les jokers sont acceptés.
Les fichiers déjà présents dans l’archive ZIP sont remplacés.
La fonction renvoie True si tout se passe bien ou False dans le cas contraire et renseigne alors les variables publiques ZIP_ErrNumber et ZIP_ErrDescription avec respectivement le code de l’erreur Err.Number et sa description Err.Description.
Les différentes étapes sont les suivantes :
- un répertoire temporaire est créé pour y décompresser l’archive ZIP ;
- un second répertoire temporaire est créé pour y copier les fichiers à ajouter ;
- les fichiers décompressés du premier répertoire se trouvant en doublon sont supprimés ;
- les fichiers à ajouter sont copiés dans le premier répertoire ;
- une nouvelle archive ZIP est générée d’après les fichiers du premier répertoire ;
- les répertoires temporaires sont supprimés.
Le code de cette fonction :
------------------------------------------------------------------------------------------------------
Public Function ZIP_Ajouter(ByVal ArchiveZip As Variant, _
ByVal FichiersAAjouter As Variant) As Boolean
'------------------------------------------------------------------------------------------------------
Dim AncienCancelkey As Long, AncienDisplay As Boolean
Dim ZipPathTps As String, FilesPathTps As String
Dim ObjFSO As Object, ObjFile As Object, ObjDossier As Object
Dim T() As Variant, i As Long
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Empêche l'utilisateur d'interrompre le traitement avec Echap et active la barre d'état :
AncienCancelkey = Application.EnableCancelKey
Application.EnableCancelKey = xlDisabled
AncienDisplay = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.Cursor = xlWait
' Vérifie que l'archive ZIP n'a pas de répertoire :
If ZIP_InfoArchive(ArchiveZip, T, NomComplet) = 0 Then _
Err.Raise vbObjectError, , "L'archive " & ArchiveZip & " n'est pas disponible."
For i = 1 To UBound(T)
If InStrRev(T(i), "\") > 1 Then
Err.Raise vbObjectError, , "Il n'est pas possible d'ajouter des fichiers à " & ArchiveZip _
& " car l'archive contient des répertoires."
End If
Next i
' Création d'un répertoire temporaire pour le ZIP :
ZipPathTps = Application.DefaultFilePath & "\ADDZIP~" & Format(Date, "0") & Format(Timer, "0")
MkDir ZipPathTps
' Y décompresse le ZIP :
If ZIP_Decompresser(ArchiveZip, ZipPathTps) = False Then _
Err.Raise vbObjectError, , "Erreur de décompression de " & ArchiveZip
' Création d'un répertoire temporaire pour les fichiers :
FilesPathTps = Application.DefaultFilePath & "\ADDFILES~" & Format(Date, "0") & Format(Timer, "0")
MkDir FilesPathTps
' Si c'est un répertoire passé en argument des fichiers a ajouter alors lui mettre les jokers :
If IsFolderExists(FichiersAAjouter) = True Then
If Right(FichiersAAjouter, 1) <> "\" Then FichiersAAjouter = FichiersAAjouter & "\"
FichiersAAjouter = FichiersAAjouter & "*.*"
End If
' Copie les fichiers sources dans le répertoire temporaire (CopyFile est synchrone) :
' Générera une erreur "Fichier introuvable" si aucun fichier à copier :
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
ObjFSO.CopyFile FichiersAAjouter, FilesPathTps & "\"
' Boucle sur ces fichiers pour supprimer ceux du zip :
Set ObjDossier = ObjFSO.GetFolder(FilesPathTps)
For Each ObjFile In ObjDossier.Files
KillFile ZipPathTps & "\" & ObjFile.Name
Next ObjFile
' Copie les fichiers dans le répertoire ZIP :
ObjFSO.CopyFile FilesPathTps & "\*.*", ZipPathTps & "\"
' Création d'une nouvelle archive ZIP :
If ZIP_Compresser(ArchiveZip, ZipPathTps & "\*.*") = False Then _
Err.Raise vbObjectError, , "Erreur de Compression de " & ArchiveZip
' Renvoie VRAI si tout s'est bien passé :
ZIP_Ajouter = True
' Gestion des erreurs (renseigne ZIP_ErrNumber et ZIP_ErrDescription en cas d'erreur et renvoie False):
Gest_Err:
ZIP_ErrNumber = Err.Number: ZIP_ErrDescription = Err.Description
' Cas de l'erreur "Fichier introuvable":
If Err.Number = 53 Then ZIP_ErrDescription = "Aucun fichier à ajouter depuis " & FichiersAAjouter
Err.Clear
' Efface les répertoires temporaires :
KillAllFolders ZipPathTps
KillAllFolders FilesPathTps
' Restaure l'interruption du traitement et la barre d'état :
Application.EnableCancelKey = AncienCancelkey
Application.StatusBar = False
Application.DisplayStatusBar = AncienDisplay
Application.Cursor = xlDefault
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
Exemples d’appels de cette fonction :
- pour ajouter les fichiers « .xlsm » du dossier « Dossier » à l’archive « MonFichier.zip » situé dans le dossier « Archive » :
ZIP_Ajouter("C:\Archive\MonFichier.zip", "C:\Dossier\*.xlsm") ; - pour ajouter les fichiers du dossier « Dossier » à cette même archive :
ZIP_Ajouter("C:\Archive\MonFichier.zip", "C:\Dossier\*.*")
Ou
ZIP_Ajouter("C:\Archive\MonFichier.zip", "C:\Dossier").
Notez que les éventuels sous-répertoires ne sont pas ajoutés.
VII. Fonction de suppression « ZIP_Supprimer »▲
Cette fonction permet de supprimer un ou plusieurs fichiers dans une archive ZIP existante.
J’imagine que vous ne devriez pas en avoir souvent besoin, mais au cas où, sachez qu’elle existe.
Puisque la méthode Delete n’existe pas dans l’objet NameSpace, l’astuce pour supprimer un fichier est d’utiliser la méthode MoveHere pour le déplacer dans un dossier temporaire, puis de l’y supprimer.
ZIP_Supprimer accepte les arguments suivants :
- ArchiveZip : l’adresse et le nom de l’archive ZIP concernée ;
- FichiersASupprimer : le nom du fichier ou des fichiers à supprimer (chemin + nom), les jokers sont acceptés.
La fonction renvoie True si tout se passe bien ou False dans le cas contraire et renseigne alors les variables publiques ZIP_ErrNumber et ZIP_ErrDescription avec respectivement le code de l’erreur Err.Number et sa description Err.Description.
Le code de cette fonction :
------------------------------------------------------------------------------------------------------
Public Function ZIP_Supprimer(ByVal ArchiveZip As Variant, _
ByVal FichiersASupprimer As String) As Boolean
'------------------------------------------------------------------------------------------------------
Dim ShellApp As Object, Cible As Object
Dim TpsFilePath As Variant, TailleFichier As Long
Dim AncienCancelkey As Long, AncienDisplay As Boolean
Dim T() As Variant, TT() As Variant, i As Long
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Empêche l'utilisateur d'interrompre le traitement avec Echap et active la barre d'état :
AncienCancelkey = Application.EnableCancelKey
Application.EnableCancelKey = xlDisabled
AncienDisplay = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.Cursor = xlWait
' Lecture des fichiers de l'archive :
i = ZIP_InfoArchive(ArchiveZip, T, NomComplet)
i = ZIP_InfoArchive(ArchiveZip, TT, Taille)
If i = 0 Then Err.Raise vbObjectError, , "L'archive " & ArchiveZip & " n'est pas disponible."
' Création d'un répertoire temporaire où seront copiés les fichiers concernés :
TpsFilePath = Application.DefaultFilePath & "\Del~" & Format(Date, "0") & Format(Timer, "0")
MkDir TpsFilePath
' Création d'un objet Shell :
Set ShellApp = CreateObject("Shell.Application")
' Création d'un objet sur la cible où décompresser :
Set Cible = ShellApp.Namespace((TpsFilePath))
' Traitements :
Application.StatusBar = "ZIP_Supprimer - Suppression de " & FichiersASupprimer
DoEvents
' Correction de FichiersAExtraire s'il ne commence pas par "\", "?" ou "*":
If Left(FichiersASupprimer, 1) <> "\" And Left(FichiersASupprimer, 1) <> "?" And Left(FichiersASupprimer, 1) <> "*" Then
FichiersASupprimer = "\" & FichiersASupprimer
End If
' Boucle sur les fichiers de l'archive :
For i = 1 To UBound(T)
' Si le fichier est a supprimer alors le déplace dans le répertoire temporaire :
If UCase(T(i)) Like UCase(FichiersASupprimer) Then
' Déplace le fichier :
Cible.MoveHere (ArchiveZip & T(i))
' Si la taille du répertoire est différente de celle attendue c'est que le traitement a été annulé :
If FilesSizeInFolders(TpsFilePath) <> TT(i) Then _
Err.Raise vbObjectError, , "Suppression de " & T(i) & " annulée."
' Supprime le fichier du dossier temporaire :
KillAllFilesInFolder TpsFilePath, False
' Indique qu'au moins une suppression est réalisée :
ZIP_Supprimer = True
End If
Next i
' Si aucun fichier n'a été trouvé :
If ZIP_Supprimer = False Then Err.Raise vbObjectError, , "Aucun fichier trouvé dans l'archive " & ArchiveZip _
& " pour la demande " & FichiersASupprimer
' Gestion des erreurs (renseigne ZIP_ErrNumber et ZIP_ErrDescription en cas d'erreur et renvoie False) :
Gest_Err:
ZIP_ErrNumber = Err.Number: ZIP_ErrDescription = Err.Description
If ZIP_ErrNumber <> 0 Then ZIP_Supprimer = False
Err.Clear
' Efface le répertoire temporaire :
KillAllFolders TpsFilePath
' Restaure l'interruption du traitement et la barre d'état :
Application.EnableCancelKey = AncienCancelkey
Application.StatusBar = False
Application.DisplayStatusBar = AncienDisplay
Application.Cursor = xlDefault
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
Exemples d’appels de cette fonction :
- pour supprimer le fichier « Test.txt » situé à la racine de l’archive « MonFichier.zip » :
ZIP_Supprimer ("C:\Archive\MonFichier.zip", "\Test.txt")
Ou (puisque la barre oblique est ajoutée automatiquement quand le premier caractère n’est pas un joker) :
ZIP_Supprimer ("C:\Archive\MonFichier.zip", "Test.txt") ; - pour supprimer tous les fichiers « xlsm » situés à la racine de l’archive « MonFichier.zip » et aussi dans tous les sous-dossiers :
ZIP_Supprimer ("C:\Archive\MonFichier.zip", "*.xlsm") ; - pour supprimer tous les fichiers « .xlsm » situés dans le dossier « Dossier » de l’archive « MonFichier.zip » et ses sous-dossiers :
ZIP_Supprimer ("C:\Archive\MonFichier.zip", "\Dossier\*.xlsm").
Voir la fonction ZIP_InfoArchive pour bien comprendre cette notion de dossier dans une archive ZIP
VIII. Conclusion▲
Les fonctions présentées ici pour compresser ou décompresser des fichiers au format ZIP sont rudimentaires, mais devraient suffire pour couvrir la majorité de vos besoins.
Rien à voir donc avec les multiples possibilités qu’offre un logiciel tiers tel que 7-Zip que vous pouvez lancer en ligne de commande depuis le VBA (voir cette page : https://7ziphelp.com/7zip-command-line?lang=fr) en appelant « 7z.exe ».
Le but étant avant tout de proposer aux développeurs VBA une solution qui leur permet d’être totalement indépendants de la configuration logicielle des utilisateurs, ainsi que de démontrer que le VBA sait, aussi, faire cela.
Bonne programmation.
Laurent OTT.
2021.
IX. Remerciements▲
Je remercie Pierre Fauconnier et gaby277 pour leur relecture technique, leurs tests et leurs très nombreux conseils, et escartefigue pour la correction orthographique.
Ainsi que toute l’équipe de Developpez.com qui participe à la maintenance du site.
X. Fichier joint▲
Vous trouverez le fichier Windows-Zip.xlsm qui contient les fonctions étudiées dans cette documentation regroupées dans le module « ZIP ».
- Le module « Tools » contient les fonctions issues du billet de Pierre Fauconnier pour gérer un fichier log.
- Le module « Exemple » est un exemple d’utilisation avec un fichier log généré dans le répertoire de l’application.
- le module « Annexe » reprend le code expliqué en annexe.
XI. Annexe - L’en-tête d’un fichier au format ZIP▲
Les fichiers au format ZIP sont reconnaissables à leur signature, c’est-à-dire leurs quatre premiers octets, notés en hexadécimal « 50 4B 05 06 »(6).
Cette signature est le premier élément de leur en-tête.
Le site https://users.cs.jmu.edu/buchhofp/forensics/formats/pkzip.html en donne le détail :
- la signature : 4 octets ;
- la version : 2 octets ;
- les options de compression : 2 octets ;
- la méthode de compression : 2 octets ;
- l’heure de compression : 2 octets qui se décomposent en
- bits 0 à 4 : les secondes divisées par 2,
- bits 5 à 10 : les minutes,
- bits 11 à 15 : les heures ; - la date de compression : 2 octets qui se décomposent en
- bits 0 à 4 : le jour,
- bits 5 à 8 : le mois,
- bits 9 à 15 : le nombre d’années depuis 1980 ; - une valeur de contrôle de l’algorithme de compression : 4 octets ;
- la taille du fichier compressé : 4 octets ;
- la taille du fichier décompressé : 4 octets ;
- le nombre de caractères du nom du fichier : 2 octets ;
- le nombre de caractères du champ supplémentaire : 2 octets ;
- le nom du fichier compressé : taille variable (indiquée plus haut) ;
- le champ supplémentaire : taille variable (indiquée plus haut).
Remarques :
- Le nom du fichier est codé d’après le jeu de caractères du DOS(7) et non pas suivant la norme utilisée par Windows. Ainsi la lettre « é » est codée 130 au lieu de 233.
Il conviendra donc de faire une conversion pour renvoyer correctement le nom du fichier.
En VBA, nous utiliserons l’API « OemToCharA » pour faire cela. - Lorsque le nom du fichier inclut des répertoires, ceux-ci sont séparés par une barre oblique inversée « / » et non pas une barre oblique ordinaire « \ ». Ce sera à corriger.
La taille de l’en-tête des fichiers ZIP est donc variable.
Elle fait 30 octets, plus le nombre de caractères du nom du fichier, plus le nombre de caractères du champ supplémentaire.
À la suite de l’en-tête vient le code compressé.
Si l’archive ZIP contient un autre fichier, un en-tête est ajouté, suivi des données compressées.
On peut atteindre directement ce nouvel en-tête en faisant un décalage (Offset) de la taille de l’en-tête précédent plus la taille des données compressées.
Un exemple pour résumer cela :
- Signature : 50 4b 03 04 = 67 324 752
- Version : 0x14 = 20 = 2.0
- Options de compression : 0
- Méthode de compression : 0x08 = deflated
- Heure de compression : 0x7d1c = 01111 101000 11100
- Heures : 01111 = 15
- Minutes : 101000 = 40
- Secondes : 11100 = 28 x 2 = 56
- Date de compression : 0x354b = 0011010 1010 01011
- Année : 0011010 = 26 + 1980 = 2006
- Mois : 1010 = 10
- Jour : 01011 = 11
- Valeur de contrôle de l’algorithme de compression : 0x7d90e1a6 (sans importance pour nous)
- Taille compressée : 0x45 = 69 octets
- Taille décompressée : 40x4a = 74 octets
- Taille nom du fichier : 0x05 = 5 octets
- Taille du champ supplémentaire : 0x15 = 21 octets
- Nom du fichier : 0x66 0x69 0x6c 0x69 0x66 = « file1 »
- Champ supplémentaire : sans importance pour nous
L’en-tête commence au premier octet de l’archive et se termine au 56e.
Les données compressées, sur 69 octets, se terminent au 125e octet.
Et donc l’en-tête du prochain fichier zippé commence à l’octet 126.
Soit un décalage de 30 + 5 + 21 + 69 = 125.
Et 1 (l’origine) + 125 (le décalage) = 126 (la position du prochain en-tête).
Connaissant la structure de l’en-tête d’un fichier au format ZIP, nous pouvons écrire une fonction qui renvoie le nom des fichiers contenus dans l’archive et leur taille cumulée une fois décompressés.
Quelques explications sur le code avant de découvrir la fonction HeaderZipFile.
Commençons par la déclaration de l’API « OemToChar » en amont des fonctions dans le module de programmation :
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal StrIn As String, ByVal StrOut As String) As Long
Cette API convertira le nom du fichier codé d’après le jeu de caractères du DOS au format utilisé par Windows, la différence portant sur les caractères spéciaux (code ASCII supérieur à 127).
L’en-tête sera mémorisé dans une structure personnalisée nommée arbitrairement « ZipHeader » déclarée elle aussi en amont des fonctions :
Private Type ZipHeader
Signature As Long
Version As Integer
Flags As Integer
Methode As Integer
ModifTimer As Integer
ModifDate As Integer
Crc As Long
CompresseSize As Long
UncompresseSize As Long
FileLen As Integer
ExtraLen As Integer
FileName As String * 1024
End TypeLa variable « FileName » qui contiendra le nom du fichier est déclarée comme étant une chaîne de caractères de 1 024 octets. Ce qui est bien trop et débordera donc sur le champ supplémentaire voire sur une partie des données compressées. Mais peu importe, car nous n’extrairons de cette chaîne que ses premiers caractères pour récupérer le nom du fichier. Information contenue dans « FileLen ».
Dir(ZipFullName) permet de vérifier que le fichier passé en argument existe. Dans ce cas, la fonction renvoie une valeur non vide.
L’ouverture du fichier (en accès aléatoire et lecture seule) se fait avec l’instruction :
Open ZipFullName For Binary Access Read As FileNumber Len = Len(Record)
ZipFullName : est le nom de l’archive ZIP.
FileNumber : est le numéro de fichier accordé par le système par FreeFile.
Record : est une copie de la structure personnelle préalablement déclarée par Dim Record As ZipHeader.
La lecture de l’en-tête depuis le 1er octet du fichier se fait avec :
Get FileNumber, 1, Record
Et donc, après calcul du décalage (Offset) pour lire l’en-tête suivant, cela donnera :
Get FileNumber, 1 + OffSet, Record
ConvOemToChar(Left(Record.FileName, Record.FileLen)) convertit au format ASCII de Windows les premiers caractères du nom du fichier.
La fermeture du fichier se fait par Close FileNumber.
La fonction HeaderZipFile prend en arguments :
- ZipFullName : l’adresse et le nom de l’archive ZIP ;
- DataFilesName : un tableau (en base 1) qui contiendra le nom des fichiers.
Elle renvoie la taille cumulée, en octets, des fichiers une fois décompressés.
------------------------------------------------------------------------------------------------------
Function HeaderZipFile(ByVal ZipFullName As String, DataFilesName() As Variant) As Long
'------------------------------------------------------------------------------------------------------
Dim FileNumber As Long, Nb As Integer, OffSet As Long
Dim Record As ZipHeader
' Gestion des erreurs :
Err.Clear
On Error GoTo Gest_Err
' Si le zip existe:
If Dir(ZipFullName) <> "" Then
' Ouvre le fichier zip :
FileNumber = FreeFile
Open ZipFullName For Binary Access Read As FileNumber Len = Len(Record)
Get FileNumber, 1, Record
' Tant que la signature d'un zip ordinaire est trouvée :
Do While Record.Signature = 67324752 ' 50 4b 03 04
' Mémorise le nom du fichier (avec Conversion du nom DOS en nom Windows) :
Nb = Nb + 1
ReDim Preserve DataFilesName(1 To Nb)
DataFilesName(Nb) = ConvOemToChar(Left(Record.FileName, Record.FileLen))
DataFilesName(Nb) = Replace(DataFilesName(Nb), "/", "\")
' calcule la taille cumulée des fichiers non compressés :
HeaderZipFile = HeaderZipFile + Record.UncompresseSize
' Fait un décalage dans la lecture du zip :
OffSet = OffSet + 30 + Record.FileLen + Record.ExtraLen + Record.CompresseSize
' Lit le zip pour savoir s'il y a un autre en-tête :
Get FileNumber, 1 + OffSet, Record
Loop
' Ferme le fichier :
Close FileNumber
End If
' Gestion des erreurs :
Gest_Err:
If Err.Number <> 0 Then MsgBox "Erreur: " & Err.Number & " : " & Err.Description, vbCritical, "HeaderZipFile"
Err.Clear
End Function
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Function ConvOemToChar(StrIn) As String
'------------------------------------------------------------------------------------------------------
' Convertit StrIn une chaîne à la norme DOS en norme Windows.
'------------------------------------------------------------------------------------------------------
ConvOemToChar = String(Len(StrIn), vbNullChar)
OemToChar StrIn, ConvOemToChar
End Function
'------------------------------------------------------------------------------------------------------
Un exemple d’appel de cette fonction :
------------------------------------------------------------------------------------------------------
Sub TestHeaderZipFile()
'------------------------------------------------------------------------------------------------------
Dim i As Long, T() As Variant
' Mémorise dans un tableau de base 1 le nom des fichiers de l’archive et renvoie la taille cumulée :
i = HeaderZipFile("C:\Dossier\Fichier.zip", T)
' Si tout s’est bien passé alors affiche les noms :
If i > 0 Then
For i = 1 To UBound(T)
Debug.Print T(i)
Next i
End If
End Sub
'------------------------------------------------------------------------------------------------------