XL 2013 compilation ZIP gestion d'attente

[patricktoulon]

Bonjour à tous
je suis tombé sur une discussion au sujet d'un zipage de fichier et justement en ce moment je travaille la dessus
alors ça fonctionne mais comme je suis un éternel insatisfait j'aimerais améliorer une gestion d'attente

en effet quand on compile plusieurs fichiers dans une archive si l'on met pas un wait 1 seconde entre les deux
au bout du x eme fichiers (c'est aléatoire) on tombe sur une erreur disant que le fichier est occupé
c'est bien sur évident que cette erreur est du au temps que met le shell application pour archiver dans le zip (selon le poids du fichier)
pour l'instant je me contente d'un wait une seconde
sauf sur 100 ou 200 fichiers ben mon café n'a pas le temps de refroidir car j'ai le temps d'en boire 2
si ca continue je vais sauter comme un cabri

j'aimerais donc trouver le moyen de faire une gestion d'attente plus juste

avez vous des idées
mon module

'******************************************************************************************************
'                           Collection  fichier et zip(archive)
'version 2023
'auteur patricktoulon
'ZIPPER LES FICHIERS D UN DOSSIER SANS LE DOSSIER
'******************************************************************************************************

Option Explicit
Sub ZipDossier() 'mettre le dossier dans un zip
    Dim oShell As Object, Dossier$, cheminZip$, archive As Variant

    Dossier = "C:\Users\patrick1\Desktop\Nouveau dossier"    'dossier ou sont les fichiers à archiver

    cheminZip = ThisWorkbook.Path & "\" & "EssaiDoss.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)

    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(archive).CopyHere (Dossier)

End Sub

'**********************************************************************************************************************

Sub ZipFichier() 'mettre le fichier dans un zip
    Dim oShell As Object, sFichier$, archive As Variant

    sFichier = "C:\Users\patrick1\Desktop\fich test.xlsx"

    cheminZip = ThisWorkbook.Path & "\" & "Essaifich.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)

    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(archive).CopyHere (sFichier)

    Set oShell = Nothing
    Set FSO = Nothing
End Sub

'**********************************************************************************************************************

Sub ZipallFichier() 'mettre les fichiers d'un dossier dans un zip
    Dim oShell As Object, F, Dossier$, cheminZip$, archive As Variant, i

    Dossier = "C:\Users\patrick1\Desktop\Nouveau dossier"    'dossier ou sont les fichiers à archiver

    cheminZip = ThisWorkbook.Path & "\" & "Essaiallfich.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)

    F = Dir(Dossier & "\*.xls*")
    DoEvents
    Set oShell = CreateObject("Shell.Application")
    Do While F <> ""
        'On Error Resume Next
        oShell.Namespace(archive).CopyHere (Dossier & "\" & F)

        Application.Wait Now + 0.00001 'c'est ICI que ca se passe

        F = Dir
        'On Error GoTo 0
    Loop

    Set oShell = Nothing
End Sub

'**********************************************************************************************************************

Function createArchiveZip(cheminZip$, Optional DeleteZip As Boolean = False)
    If DeleteZip Then If Dir(cheminZip) <> "" Then Kill cheminZip
    Dim FSO As Object, sBin As String, arrayBin As Variant, i&
    Set FSO = CreateObject("Scripting.FileSystemObject")
    arrayBin = 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(arrayBin): sBin = sBin & Chr(arrayBin(i)): Next i
    With FSO.CreateTextFile(cheminZip, True): .Write sBin: .Close
    End With
    Set FSO = Nothing
    createArchiveZip = cheminZip
End Function

 

[cp4]

Bonjour PatrickToulon ,

Je n'ai de réponse ou solution à te proposer. Juste pour te dire que ton fil tombe à point.
Moi aussi, il y a un bon moment que je suis tombé sur une discussion où il fallait mettre gestion d'attente.
Étant, un peu "beaucoup" brouillon, je ne sais plus où j'ai enregistré le fichier. Mais j'ai compris l'idée, je pourrais refaire un fichier illustrant la problématique.
En gros, il fallait mettre un truc (popup ou texte dans label) pour informer l'utilisateur et en arrière plan permettre l’exécution de toute une série de procédures. Je vais donc suivre avec attention ton fil.

Bonne journée.

 

[patricktoulon]

re
Bonjour @cp4 ben tu aura pas attendu longtemps
mais bon sang pourquoi je n'y ai pas pensé
en fait j'ai trouvé la solution en vb.net et je fait la même chose en vba
a savoir attendre le count +1
c’était vraiment tout bête

'******************************************************************************************************
'                           Collection  fichier et zip(archive)
'version 2023
'auteur patricktoulon

'.1° ZIPPER UN DOSSIER
'.2° ZIPPER UN FICHIER
'.3° ZIPPER LES FICHIERS D UN DOSSIER SANS LE DOSSIER
'******************************************************************************************************

Option Explicit

Sub ZipDossier()    'mettre le dossier dans un zip
    Dim oShell As Object, Dossier$, cheminZip$, archive As Variant
    Dossier = "C:\Users\patrick1\Desktop\Nouveau dossier"    'dossier ou sont les fichiers à archiver
    cheminZip = ThisWorkbook.Path & "\" & "EssaiDoss.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)
    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(archive).CopyHere (Dossier)
End Sub

'**********************************************************************************************************************

Sub ZipFichier()    'mettre le fichier dans un zip
    Dim oShell As Object, sFichier$, archive As Variant, cheminZip$
    sFichier = "C:\Users\patrick1\Desktop\fich test.xlsx"
    cheminZip = ThisWorkbook.Path & "\" & "Essaifich.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)
    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(archive).CopyHere (sFichier)
End Sub

'**********************************************************************************************************************

Sub ZipallFichier()    'mettre les fichiers d'un dossier dans un zip
    Dim oShell As Object, F, Dossier$, cheminZip$, archive As Variant, i, A&
    Dossier = "C:\Users\patrick1\Desktop\Nouveau dossier"    'dossier ou sont les fichiers à archiver

    cheminZip = ThisWorkbook.Path & "\" & "Essaiallfich.zip"    ' chemin de l'archive
    archive = createArchiveZip(cheminZip, True)

    F = Dir(Dossier & "\*.xls*")
    DoEvents
    Set oShell = CreateObject("Shell.Application")
    Do While F <> ""
        'On Error Resume Next
        A = oShell.Namespace(archive).Items.Count    'on repère le count avant la copie d'un fichier

        oShell.Namespace(archive).CopyHere (Dossier & "\" & F)    'copie du fichier itéré dans la boucle dir

        Do Until oShell.Namespace(archive).Items.Count = A + 1: DoEvents: Loop    ' tout simplement on attent que le count soit celui d'avant la copie + 1

        F = Dir
        'On Error GoTo 0
    Loop
    Set oShell = Nothing
End Sub

'**********************************************************************************************************************

Function createArchiveZip(cheminZip$, Optional DeleteZip As Boolean = False)
    If DeleteZip Then If Dir(cheminZip) <> "" Then Kill cheminZip
    Dim FSO As Object, sBin As String, arrayBin As Variant, i&
    Set FSO = CreateObject("Scripting.FileSystemObject")
    arrayBin = 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(arrayBin): sBin = sBin & Chr(arrayBin(i)): Next i
    With FSO.CreateTextFile(cheminZip, True): .Write sBin: .Close
    End With
    Set FSO = Nothing
    createArchiveZip = cheminZip
End Function

pour te donner une idée je passe de 71 secondes pour 60 fichiers à 11 secondes
c'est suffisant pour dire que c'est une amélioration

 

[cp4]

Re,

Bonjour @cp4 ben tu aura pas attendu longtemps

Confus, finalement ce n'est pas le même truc. Je vais donc attendre plus longtemps.
Je dois faire un fichier exemple à joindre au fil que j'ouvrirai.
Bien que je zippe pas, je mets ton code dans ma petite Biblio.
Merci pour ta bonne intention.

 

[patricktoulon]

re
c'est quoi ton soucis à toi
ouvre un post je regarde j'ai peut être déjà

 

[cp4]

re
c'est quoi ton soucis à toi
ouvre un post je regarde j'ai peut être déjà

Merci beaucoup pour ta disponibilité et ta gentillesse.
Je n'ai pas beaucoup de temps en ce moment, débordé par d'autres tâches prioritaires.
Dès que j'aurais un moment, je ferai un fichier pour ouvrir un post.

Bonne soirée.