Autres je n'arrive pas a extraire les éléments d'une archive

patricktoulon · 8 Mars 2021

bonjour a tous
je n'arrive pas a extraire les éléments d'une archive vers un dossiers

VB:

Sub test()
    Dim sh, sampleC$, sampleZip$, i , n
    
      
    sampleC = ThisWorkbook.Path & "\toto.xlsm"
    sampleZip = ThisWorkbook.Path & "\toto.zip"
    decompil = ThisWorkbook.Path & "\decompilation"
    
    If Dir(sampleZip) <> "" Then Kill sampleZip

    With Workbooks.Add: .SaveAs Filename:=sampleC, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False: .Close: End With
    Application.ScreenUpdating = True
    Do While Dir(sampleC) = "": DoEvents: Loop    'attente creation
    Name sampleC As sampleZip    'conversion en archive ZIP
    Do While Dir(sampleZip) = "": DoEvents: Loop


 Set sh = CreateObject("shell.application")
 
    'sh.Namespace(decompil).movehere sh.Namespace(sampleZip).items.Item("_rels")'fonctionne pas
    Set n = sh.Namespace(sampleZip)
    For Each i In n.items ' ici ça plante
        Debug.Print i.Path
    Next
End Sub

puré je m'arrache les cheveux

dysorthographie · 8 Mars 2021

Bonjour Patrick,
je suis pas certain d'avoir compris!

Code de kiki29!

Code:

 Option Explicit
 
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim DossierZip As Variant
Dim DossierDezip As Variant
    
    DossierZip = ThisWorkbook.Path & "\toto.zip"
    DossierDezip = ThisWorkbook.Path & "\Data"
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(DossierDezip) Then
        FSO.DeleteFile DossierDezip & "\*.*", True
        FSO.DeleteFolder DossierDezip & "\*.*", True
    End If
    Set FSO = Nothing
 
    If CreationDossier(DossierDezip) Then
 
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(DossierDezip).CopyHere oApp.Namespace(DossierZip).items
        Set oApp = Nothing...

Bernard_XLD · 8 Mars 2021

Bonjour Patrick

ton code me semble correct mais essayes

VB:

sh.Namespace(ThisWorkbook.Path).CopyHere sh.Namespace(sampleZip).items

@+

patricktoulon · 8 Mars 2021

re
non j'ai toujours la même erreur (91) " variable indéfinie "

patricktoulon · 8 Mars 2021

je m'arrache les cheveux depuis tout a l'heure

Bernard_XLD · 8 Mars 2021

je cherche, je pige pas non plus

laurent950 · 8 Mars 2021

Bonjour Patrick,

Si cela peu t'aider Patrick, les références qui m'on servis

Dezipper un dossier depuis une macro VBA Excel ?

Meilleure réponse: ci-dessous exemple de code pour dézipper des fichiers se trouvant dans un répertoire donné Sub Unzip() Dim FSO As Object Dim ShApp As Object Dim dossier As Object, fichier As Object Dim répertoire_zip As String,...

forums.commentcamarche.net

Dezipper fichier automatiquement - VB/VBA/VBS - Programmation - FORUM HardWare.fr

forum.hardware.fr

Le code :

VB:

Sub test()
    Dim sh, sampleC$, sampleZip$, i, n
    
    sampleC = ThisWorkbook.Path & "\toto.xlsm"
    répertoire_zip = ThisWorkbook.Path
    sampleZip = ThisWorkbook.Path & "\toto.zip"
    decompil = ThisWorkbook.Path & "\decompilation"
  
    If Dir(sampleZip) <> "" Then Kill sampleZip

    With Workbooks.Add: .SaveAs Filename:=sampleC, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False: .Close: End With
    Application.ScreenUpdating = True
    Do While Dir(sampleC) = "": DoEvents: Loop    'attente creation
    Name sampleC As sampleZip    'conversion en archive ZIP
    Do While Dir(sampleZip) = "": DoEvents: Loop
'
    Set sh = CreateObject("shell.application")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set n = FSO.GetFolder(répertoire_zip)
'
    For Each fichier In n.Files
        If FSO.GetExtensionName(fichier.Path) = "zip" Then
            Debug.Print fichier.Path
            'sh.Namespace(répertoire_zip).CopyHere sh.Namespace(fichier.Path).items
            'sh.Namespace(decompil).CopyHere sh.Namespace(fichier.Path).items
            ' Boucle sur les Item
                For Each i In sh.Namespace(fichier.Path).items ' ici ça Fonctionne
                    Debug.Print i.Path
                    sh.Namespace(decompil).CopyHere i.Path   ' Recopie dans le Répertoire decompil
                Next
        End If
    Next
End Sub

patricktoulon · 8 Mars 2021

ok laurent bonjour
ça voudrais dire fichier.path est différent que le chemin écrit en dur
c'est quand même étonnant que sur mon costumUI creator ça marche
maintenant j'en suis a la dernière etape
j'arrive a renvoyer un dossier dynamique "customUI avec tout ces composants et le nouveau _rels mais le dernier contentType.xml ne veux pas passer

je garde ton idée que je vais tester mais lister c'est pas le but
le but est d'extraire et d'injecter des fichiers ou dossiers

dysorthographie · 8 Mars 2021

Bonjour Patrick,
je suis pas certain d'avoir compris!

Code de kiki29!

Code:

 Option Explicit
 
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim DossierZip As Variant
Dim DossierDezip As Variant
    
    DossierZip = ThisWorkbook.Path & "\toto.zip"
    DossierDezip = ThisWorkbook.Path & "\Data"
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(DossierDezip) Then
        FSO.DeleteFile DossierDezip & "\*.*", True
        FSO.DeleteFolder DossierDezip & "\*.*", True
    End If
    Set FSO = Nothing
 
    If CreationDossier(DossierDezip) Then
 
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(DossierDezip).CopyHere oApp.Namespace(DossierZip).items
        Set oApp = Nothing
 
        Application.StatusBar = "Les fichiers Dézippés se trouvent dans : " & DossierDezip
    End If
End Sub
 Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":") = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\")
    Else
        Ar = Split(sChemin, "\")
    End If
 
    sTmp = Ar(0)
    ChDrive sTmp
 
    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i
 
    If Dir(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

job75 · 8 Mars 2021

Bonjour à tous,

Chez moi ceci va bien à condition de ne pas déclarer les variables :

VB:

Sub a()
sampleC = ThisWorkbook.Path & "\toto.xlsm"
sampleZip = ThisWorkbook.Path & "\toto.zip"
If Dir(sampleC) <> "" Then Kill sampleC 'RAZ
If Dir(sampleZip) <> "" Then Kill sampleZip 'RAZ
With Workbooks.Add: .SaveAs sampleC, xlOpenXMLWorkbookMacroEnabled: .Close: End With
Do While Dir(sampleZip) = "": Name sampleC As sampleZip: DoEvents: Loop
Set sh = CreateObject("shell.application")
For Each i In sh.Namespace(sampleZip).items
    Debug.Print i.Path
Next
End Sub

A+

patricktoulon · 8 Mars 2021

🤣 cc' Robert

et oui bonjour job75 j'ai vu ça aussi ou en variant
étonnant cet object 🤔
après lister ca va ca passe
mais le namespace(destination ) movehere namespaces(source) et vice et versa marche pour les 1,2 premier et le 3eme pouf pas d'erreur mais rien

Bernard_XLD · 8 Mars 2021

problème shell32 sous win 64 ?

patricktoulon · 8 Mars 2021

re
ma fois je sais pas j'ai cherché voir si d'autres ont eu ce problème ,mais je n'ai trouvé de probant
ça m'ennuie j'ai juste ce dernier fichier a mettre et c'est bon j'ai plus l'erreur de fichier a réparer quand j'ouvre le fichier après
c'est peut être les caractères particulier"[contentTipe].xml"
je vais essayer sans voir si c'est ça

job75 · 8 Mars 2021

job75 à dit:
à condition de ne pas déclarer les variables :

Ces déclarations sont acceptées :

VB:

Dim sampleC$, sampleZip, sh As Object, i As Object

Curieusement c'est sampleZip qui doit être Variant...

patricktoulon · 8 Mars 2021

re
tiens donc!!! 🤔

a ben ca c'est la meilleure alors en injection dans l'archive c'est le contraire

patricktoulon · 8 Mars 2021

j'ai testé c'est pas les caractères particuliers
bon je vous ait fait un hersât du projet avec la fonction de compilation
j'ai remplacé mon userform creator par des code xml dans les cellules pour les tests ça ira très bien
lancer la sub test

la fonction est sensée

créer un classeur 'ok
le zipper 'ok
extraire le dossier _rels d'origine 'ok(je le jette)
créer un dossier dezip
extraire le [contenttType].xml dans dezip 'ok
créer dans dezip un dossier rel avec le new ".rels" a l’intérieur 'ok
créer dans dezip un dossier customUI avec les 2 customUI xml (2007 et les supérieurs 'ok
créer un dossier customUI_rel dans le dossier customUI 'ok
créer un customUI_rel pour les relationship des image 'ok
envoyer le dossier image du projet dans le dossier customUI de dezip 'ok
modifier le [contenttType].xml ajouter les extension d'images utilisées pour les icons dans dezip 'ok
réinjecter le new _rels 'ok
réinjecter tout le customui 'ok
réinjecter le [contenttType].xml'C EST ICI QUE CA LE FAIT PAS pas ok et pas de msg d'erreur
et enfin rechanger l'extension "zip" pour"xlsm" sur le sample.zip 'ok mais bloqué pour les tests

voila maintenant nous avons le même code

si vous prenez le contentTypexml et que vous l'ajoutez manuellement
dans l'archive et changez l'extension le classeur fonctionne avec le new ribbon

Autres je n'arrive pas a extraire les éléments d'une archive

patricktoulon

XLDnaute Barbatruc

dysorthographie

Bernard_XLD

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Dezipper un dossier depuis une macro VBA Excel ?

Dezipper fichier automatiquement - VB/VBA/VBS - Programmation - FORUM HardWare.fr

patricktoulon

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

job75

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Autres je n'arrive pas a extraire les éléments d'une archive

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency