XL 2013 le dézipage ne fonctionne pas

patricktoulon · 7 Mai 2020

Bonjour a tous
j'ai un petit soucis avec dezip and rezip
j'aimerais sortir le dossier "_rels" et mettre le mien
ou l’écraser avec le mien
pour le sortir movehere ne fonctionne pas
pour l’écrasement j'ai un msgbox me disant de renommer le fichier donc l’écrasement niet

voir les lignes "sortie du dossier" et "insertion du dossier"

VB:

Public newprojetFolder$
Public SampleC$
Public SampleZip$
Public previewZip$
Public dézipé$
Sub newprojet()
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    newprojetFolder = ThisWorkbook.Path & "\NewProjet"
    dézipé = newprojetFolder & "\dezip"
    If Dir(newprojetFolder, vbDirectory) <> "" Then deleteFolder newprojetFolder
    MkDir newprojetFolder
    MkDir newprojetFolder & "\dezip"
    MkDir newprojetFolder & "\dezip\_rels"
    MkDir newprojetFolder & "\dezip\customUI"

    SampleC = newprojetFolder & "\sample.xlsm"
    SampleZip = newprojetFolder & "\sample.zip"
    previewZip = newprojetFolder & "\preview.zip"
    With Workbooks.Add: .SaveAs Filename:=SampleC, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False: .Close: End With
    Application.ScreenUpdating = True
    Do While Dir(SampleC) = "": DoEvents: Loop
    Name SampleC As SampleZip
    FileCopy SampleZip, previewZip
    CreatedemoXML
    DeplacerFichierDanspreviewsZip
End Sub

Sub deleteFolder(dossier)
    With CreateObject("Scripting.FileSystemObject"): .GetFolder(dossier).Delete: End With
End Sub
Sub CreatedemoXML()
    fichier = newprojetFolder & "\dezip\customUI\customUI14.xml"
    x = FreeFile: Open fichier For Append As #x: Print #x, [A2].Text: Close #x
    fichier = newprojetFolder & "\dezip\customUI\customUI.xml"
    x = FreeFile: Open fichier For Append As #x: Print #x, [A3].Text: Close #x
    fichier = newprojetFolder & "\dezip\_rels\.rels"
    x = FreeFile: Open fichier For Append As #x: Print #x, [A1].Text: Close #x
End Sub


Sub DeplacerFichierDanspreviewsZip()

'gestion des erreurs
    On Error GoTo ErreurCompression

'définition des variables
    Dim ApplicationArchivage As Object
    Dim dossier, dossier2, FichierZip
  
'informations sur les fichiers (chemins & noms)
     FichierZip = newprojetFolder & "\preview.zip"
     dossier = newprojetFolder & "\dezip\customUI"
    dossier2 = newprojetFolder & "\dezip\_rels"
  
'je voudrais sortir le dossier "_rels"
'ApplicationArchivage.Namespace(newprojetFolder).moveHere ApplicationArchivage.Namespace(FichierZip).items.Item("_rels") ' sortie du dossier

'copier le dossier dans l'archive
    Set ApplicationArchivage = CreateObject("Shell.Application")
    ApplicationArchivage.Namespace(FichierZip).copyHere dossier
    Application.Wait Now + 0.00001

'si je n'arrive pas a le sortir au moins l'ecraser avec celui là!!!!!!!!!!!
ApplicationArchivage.Namespace(FichierZip).copyHere dossier2' insertion du dossier
   'Message final
    MsgBox "L'archivage a été mis à jour..."

Exit Sub
ErreurCompression:
    MsgBox "Une erreur s'est produite..."
End Sub

patricktoulon · 8 Mai 2020

bonjours a tous
il n'y a vraiment personne que ça intéresse?
aujourd'hui j'essaie de sortir un dossier et je plante toujours sur la ligne d'extraction
que ce soit "copyhere" ou "movehere" j'ai toujours l'erreur 91 "variable block non définie"
je pige plus rien

au secours !!!je me noie dans 10 lignes de code

VB:

Sub startingProject()
    Dim NewProjet$, DeZip$, zipzip$,SampleC, ApplicationArchivage As Object
    NewProjet = ThisWorkbook.path & "\NewProjet"
    DeZip = NewProjet & "\dezip"
    SampleC = NewProjet & "\sample.xlsm"
    zizip = NewProjet & "\sample.zip"

    If Dir(NewProjet, vbDirectory) <> "" Then deleteFolder (NewProjet)
    MkDir (NewProjet)
    If Dir(DeZip, vbDirectory) = "" Then MkDir (DeZip)

    'creation archive sur la base du xlsm
    Application.ScreenUpdating = False
    With Workbooks.Add: .SaveAs Filename:=SampleC, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False: .Close: End With
    Application.ScreenUpdating = True
    Do While Dir(SampleC) = "": DoEvents: Loop
    Name SampleC As zizip



    'On Error GoTo ErreurCompression
    Set ApplicationArchivage = CreateObject("Shell.Application")
    MsgBox ApplicationArchivage.Namespace(zizip).items.Item(1).Name
    
    ApplicationArchivage.Namespace(DeZip).moveHere ApplicationArchivage.Namespace(zizip).items.Item("_rels")
    Set ApplicationArchivage = Nothing
    Exit Sub
ErreurCompression:
    MsgBox "Une erreur s'est produite..."
End Sub
Sub deleteFolder(dossier)
    With CreateObject("Scripting.FileSystemObject"): .GetFolder(dossier).Delete: End With
End Sub

laurent950 · 8 Mai 2020

Bonjour Patrick

patricktoulon à dit:
DeZip = NewProjet & "\dezip"

Il manque l'extension !
DeZip = NewProjet & "\dezip" en rapport avec cette ligne "
"ApplicationArchivage.Namespace(DeZip).moveHere ............"

DeZip = NewProjet & "\dezip.zip"

J'ai trouvé cela ici :

VBA et Zip: compresser et décompresser des fichiers

Codes sources VBA prêts à l'utilisation pour compresser et décompresser des fichiers vers et à partir d'un archive ZIP...

excel-malin.com

patricktoulon · 8 Mai 2020

Bonjour @laurent
deZip est un dossier
a tu déjà vu une extension dans le nom un dossier ?

laurent950 · 8 Mai 2020

re,

deZip est un dossier
a tu déjà vu une extension dans le nom un dossier ?
Essaie de mettre le chemin du dossier complet c'est a dire :
le chemin complet & deZip
Regarde ici il y a le chemin complet
https://docs.microsoft.com/en-us/windows/win32/shell/folder-movehere

patricktoulon · 8 Mai 2020

re
bon laurent t'inquiet j'y suis arrivé
la raison n'est pas là elle est que shell namespaces imposes des contraintes de temps et d'affiliation
1°de temps pour laisser le temps de faire le job
2°d'affiliation :quand on ce sert de namespace(source ) namespace(dossier ou fichier) les fichiers dans l'un ou dans l'autre ne peuvent plus être touchés avant la fin

donc voila la demo
le but étant de créer a la volée un fichier xlsm avec son ruban perso
ouvrir le demo.xlsm après

finalement j'ai trouvé tout seul

VB:

Dim Folder_NewProjet$, Folder_DeZip$, zipzip$, Folder_customUI, Folder_rels, customUIxml, customUI14xml, relXML, SampleC$
Sub startingProject2()
    Dim ApplicationArchivage As Object, motifs
    Application.ScreenUpdating = False

    Folder_NewProjet = ThisWorkbook.path & "\NewProjet"
    Folder_DeZip = Folder_NewProjet & "\DeZip"

    SampleC = Folder_NewProjet & "\sample.xlsm"
    zizip = Folder_NewProjet & "\sample.zip"
    tempo = Folder_NewProjet
    Folder_customUI = Folder_DeZip & "\customUI"
    Folder_rels = Folder_DeZip & "\_rels"
    customUIxml = Folder_customUI & "\customUI.xml"
    customUI14xml = Folder_customUI & "\customUI14.xml"
    relXML = Folder_rels & "\.rels"
    If Dir(Folder_NewProjet, vbDirectory) <> "" Then deleteFolder2 (Folder_NewProjet)
    MkDir (Folder_NewProjet): MkDir Folder_DeZip: MkDir Folder_customUI: MkDir Folder_rels

    'creation archive sur la base d'un xlsm vierge
    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 zizip    'conversion en archive ZIP

    motif = "la décompression"
    On Error GoTo ErreurCompressiondecompression
    '*********************************************************
    ' suppression  du dossier "_rels de l'archive

    Set ApplicationArchivage = CreateObject("Shell.Application")
    ApplicationArchivage.Namespace(tempo).moveHere ApplicationArchivage.Namespace(zizip).items.Item("_rels")
    Set ApplicationArchivage = Nothing

    Do: DoEvents: Loop While Dir(tempo & "\_rels", vbDirectory) = ""    ' attente d'extraction
    deleteFolder2 tempo & "\_rels"    ' suppression de ce dossier
    '*********************************************************
    ' MsgBox "l'Archive  a été crée et le dossier ""_rels"" en a  été supprimé"

    CreatedemoXML2    ' creation des customui de demo

    Do: DoEvents: Loop While Dir(relXML) = ""


    '*********************************************************
    'injection des dossier customui et rels dans l'archive
    motif = " l'injection dans l'archive"
    Set ApplicationArchivage = CreateObject("Shell.Application")
    ApplicationArchivage.Namespace(zizip).copyHere ApplicationArchivage.Namespace(Folder_customUI)
    Application.Wait Now + 0.00001
    ApplicationArchivage.Namespace(zizip).copyHere ApplicationArchivage.Namespace(Folder_rels)
    Set ApplicationArchivage = Nothing
    '*********************************************************
    motif = " reconversion en ""xlsm"""
    Application.Wait Now + 0.00002
    Name zizip As SampleC  'conversion en "".xlsm""
 

    MsgBox "terminé opération reussie :)"
    Exit Sub
ErreurCompressiondecompression:
    MsgBox "Une erreur s'est produite à " & motif & vbCrLf & Err.Description
End Sub
Sub deleteFolder2(dossier)
    With CreateObject("Scripting.FileSystemObject"): .GetFolder(dossier).Delete: End With
End Sub
Sub CreatedemoXML2()
    fichier1 = customUI14xml
    x = FreeFile: Open fichier1 For Append As #x: Print #x, [A2].Text: Close #x
    fichier2 = customUIxml
    x = FreeFile: Open fichier2 For Append As #x: Print #x, [A3].Text: Close #x
    fichier3 = relXML
    x = FreeFile: Open fichier3 For Append As #x: Print #x, Replace([A1].Text, "><", ">" & vbCrLf & "<"): Close #x
End Sub

laurent950 · 8 Mai 2020

Merci Patrick,
Tu es vraiment très fort et surtout tu comprends bien le code, la structure et la logique programmation. Félicitation

patricktoulon · 8 Mai 2020

me voila paré pour créer un customui editor en live

bon il n'y a pas les macros mais le ribbon perso est là
tu l'a essayé ?

laurent950 · 8 Mai 2020

re,
Oui j'ai essayé est cela fonction sur mon ordinateur.

Par contre je ne sais pas comment cela s'articule ! il faut que j'apprenne cela c'est Extra.
Ca fonctionne à la Perfection. ce code est vraiment Génial Patrick

patricktoulon · 8 Mai 2020

OUI mais a tu ouvert le "Sample.xlsm" pour voir si l'onglet est bien là

_Thierry · 8 Mai 2020

BRAVO quelle persévérance !!!!!!

_Thierry · 8 Mai 2020

Hello Patrick, Laurent

Je confirme, celà fonctionne bien sur Windows8.1 Pro 64, Office 2013 Pro Plus 32 et le sample.XLSM contient bien le nouveau ribbon et les menus.

Comme disait Laurent, tu es impressionnant !
Bien à toi, à vous !
@+Thierry

patricktoulon · 8 Mai 2020

bonjour Thierry
oui laborieux la manip de namespace (dossier/ archive) et (vice et versa)
c'est juste un tour de passe entre deux fichier
les contraintes sont quand même pénibles

le transfert dans dossier ou sub dossier est sensible
si riche arborescence dans dossier de l'archive temps allongé
etc...

il faut faire avec
mais j'ai ma base
je suis en train de voir a simplifier pour accélérer

et qui a dit que l'on pouvait pas créer un ribbon dynamique hein!!
et si je le fait en xla et que je l'open tout de suite c'est pas du dynamique ca ??

patricktoulon · 8 Mai 2020

Merci Laurent et Thierry pour le test

_Thierry · 8 Mai 2020

Ne me parle pas de "Dynamique" LoL
Je suis les deux pieds dedans au taff avec Microsoft Dynamics Business Central que l'on doit adapter à nos besoins customisés à bloc avec les anciennes versions NAV (ou Navision)... Ca aussi ce n'est pas simple...

Bon courage
@+Thierry

XL 2013 le dézipage ne fonctionne pas

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

VBA et Zip: compresser et décompresser des fichiers

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

_Thierry

XLDnaute Barbatruc

_Thierry

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

_Thierry

XLDnaute Barbatruc

Discussions similaires