Dezipper des fichiers ZIP dans répertoire différent

**munity** · 11/06/2018, 17h25

merci je testerai ta soluce
pour l'instant je mets le code sans cette modification si cela peut aider quelqu'un
voici le déroulé de la macro
dézippe tous les fichiers du répertoire ou se trouve la BDD
crée un dossier du nom du zip et y copie le dossier présent dans le zip
récupérer dans chaque dossier un fichier bien définie
le mets dans un format particulier
y ajoute des informations
exporte celui ci au format xls pret à l'emploi

macro de dézippage

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
Function DEZIPPE()
Dim RepertoireBase As String, NomFichier As String
 
'Récuperation de la liste des fichiers
RepertoireBase = Application.CurrentProject.Path & "\"
NomFichier = Dir(RepertoireBase & "*.zip", vbDirectory)
 
'On passe d'un fichier zip a l'autre
Do While NomFichier <> ""
    'Dezippage Fichier
     Dim osa As Shell
        Set osa = New Shell
            osa.Namespace((RepertoireBase)).CopyHere osa.Namespace((RepertoireBase & NomFichier)).Items
        Set osa = Nothing
 
    'Création du répertoire du fichier dézipper
    NomFicSansExt = Left(NomFichier, InStrRev(NomFichier, ".") - 1)
    RepertoireDest = Application.CurrentProject.Path & "\" & NomFicSansExt & "\"
    'If Dir(RepertoireBase & NomFicSansExt) = "" Then MkDir (RepertoireBase & NomFicSansExt)
    MkDir (RepertoireBase & NomFicSansExt)
 
    'Copie et Supprime les dossiers
        Set oFSO = New Scripting.FileSystemObject
            oFSO.CopyFolder RepertoireBase & "SIMPLES", RepertoireDest & "SIMPLES", True
            oFSO.DeleteFolder RepertoireBase & "SIMPLES", True
        Set oFSO = Nothing
 
    NomFichier = Dir
 
Loop
End Function

macro de traitement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
 
Function EXPORT_TABLE()
'Declaration des variables
Dim RepertoireBase As String, NomFichier As String
Dim R001, R002, R003, QueryDef
Dim FSO As Object, folder As Object
 
'Fonction UnZippe Fichiers
    Call DEZIPPE
 
'******************************TRAITEMENT FDC**********************************************
'Purge Table Principale
    R001 = "DELETE * FROM IMPORTATION_RECAP"
    DoCmd.RunSQL R001
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each folder In FSO.GetFolder(Application.CurrentProject.Path & "\").SubFolders
 
    NomFichier = Dir(folder.Path & "\SIMPLES\" & "pressmaker_FDC*.xls", vbDirectory)
        Do While NomFichier <> ""
            DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel8, "IMPORTATION_RECAP", folder.Path & "\SIMPLES\" & NomFichier, True '
            Debug.Print NomFichier
            NomFichier = Dir
        Loop
    Next
 
'Création Table pour Insertion Persos Poste
    R002 = "SELECT DESIGNATION, NUMPARUTION INTO DESIGNATION FROM IMPORTATION_RECAP GROUP BY DESIGNATION, NUMPARUTION"
    DoCmd.RunSQL R002
 
'Insertion Persos Poste
    R003 = "INSERT INTO IMPORTATION_RECAP ( DESIGNATION, NUMPARUTION, ADR2, ADR3, ADR4, ADR5, ADR6, LG1 ) SELECT DESIGNATION.DESIGNATION, DESIGNATION.NUMPARUTION, ""M PERSO"" AS ADR2, ""RUE DE PERSOVILLE"" AS ADR3, ""PERSO"" AS ADR4, ""PERSO"" AS ADR5, ""99999 PERSOVILLE"" AS ADR6, ""9999999"" AS LG1 FROM DESIGNATION   ORDER BY DESIGNATION.DESIGNATION"
    DoCmd.RunSQL R003
 
'Exportation du Fichier Final
    Set R004 = CurrentDb.CreateQueryDef("R004_EXPORT_TABLE", "Select * From IMPORTATION_RECAP ORDER BY NUMPARUTION, LG1 ")
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "R004_EXPORT_TABLE", Application.CurrentProject.Path & "\EXPORT_TABLE_FDC.xls"
    DoCmd.DeleteObject acTable, "DESIGNATION"
    DoCmd.DeleteObject acQuery, "R004_EXPORT_TABLE"
 
 
'******************************TRAITEMENT FDP**********************************************
    R001 = "DELETE * FROM IMPORTATION_RECAP"
    DoCmd.RunSQL R001
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each folder In FSO.GetFolder(Application.CurrentProject.Path & "\").SubFolders
 
        NomFichier = Dir(folder.Path & "\SIMPLES\" & "pressmaker_FDP*.xls", vbDirectory)
            Do While NomFichier <> ""
                DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel8, "IMPORTATION_RECAP", folder.Path & "\SIMPLES\" & NomFichier, True '
                Debug.Print NomFichier
                NomFichier = Dir
            Loop
        Next
 
'Création Table pour Insertion Persos Poste
    R002 = "SELECT DESIGNATION, NUMPARUTION INTO DESIGNATION FROM IMPORTATION_RECAP GROUP BY DESIGNATION, NUMPARUTION"
    DoCmd.RunSQL R002
 
'Insertion Persos Poste
    R003 = "INSERT INTO IMPORTATION_RECAP ( DESIGNATION, NUMPARUTION, ADR2, ADR3, ADR4, ADR5, ADR6, LG1 ) SELECT DESIGNATION.DESIGNATION, DESIGNATION.NUMPARUTION, ""M PERSO"" AS ADR2, ""RUE DE PERSOVILLE"" AS ADR3, ""PERSO"" AS ADR4, ""PERSO"" AS ADR5, ""99999 PERSOVILLE"" AS ADR6, ""9999999"" AS LG1 FROM DESIGNATION   ORDER BY DESIGNATION.DESIGNATION"
    DoCmd.RunSQL R003
 
'Exportation du Fichier Final
    Set R004 = CurrentDb.CreateQueryDef("R004_EXPORT_TABLE", "Select * From IMPORTATION_RECAP ORDER BY NUMPARUTION, LG1 ")
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "R004_EXPORT_TABLE", Application.CurrentProject.Path & "\EXPORT_TABLE_FDP.xls"
        DoCmd.DeleteObject acTable, "DESIGNATION"
        DoCmd.DeleteObject acQuery, "R004_EXPORT_TABLE"
 
'Fermeture BDD
    DoCmd.Quit
 
End Function

en espérant inspirer

david

**informer** · 11/06/2018, 17h45

Comme il y a potentiellement plusieurs fichiers ZIP, il faut faire le DIR en son entier et à chaque fois qu’un sous répertoire est inexistant le rajouter à un tableau que tu redimensionnes dynamiquement pour ajouter le sous répertoire non trouvé .

Ensuite tu boucles sur le tableau et tu crées pour chaque élément du tableau un sous répertoire
... suite du code

**munity** · 11/06/2018, 18h27

Merci pour ton idée
Mais je ne maîtrise pas du tout les tableaux dans vba

**informer** · 11/06/2018, 21h33

C’est l’occasion. Très bon tuto de silkroad ICI

**informer** · 12/06/2018, 09h24

Tuto d'autant plus excellent qu'il te donne le code. Par contre adapte le pour n'avoir qu'une dimension car ne sont enregistrés que les répertoires manquants.

Pour un tableau multidimensionnel, je préfère soit un dictionnaire soit une structure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
 
Option Explicit
 
Sub ListeFichiersRepertoire()
    Dim Repertoire As String, Fichier As String
    Dim Tableau() As Variant
    Dim x As Integer, i As Integer
    Dim VerifTab As Variant
 
    'Définit le répertoire pour la recherche
    Repertoire = "C:\Documents and Settings\dossier"
    'Recherche tous les types de fichiers
    Fichier = Dir(Repertoire & "\*.*")
 
    'Boucle sur les fichiers pour récupérer les infos
    Do While Fichier <> ""
        'Incrémente le compteur de fichiers
        x = x + 1
 
 
        '--- Redéfinit la taille de la dernière dimension du tableau
        ReDim Preserve Tableau(1 To 2, 1 To x)
        '------------------------------------
 
 
        'Récupère le nom du fichier
        Tableau(1, x) = Fichier
        'Récupère  la date et l'heure de création ou de dernière modification.
        Tableau(2, x) = FileDateTime(Repertoire & "\" & Fichier)
        Fichier = Dir
    Loop
 
 
    '--- On vérifie si le tableau est vide
    On Error Resume Next
    'VerifTab va prendre la valeur Empty si le tableau est vide.
    VerifTab = UBound(Tableau)
    On Error GoTo 0
 
    If IsEmpty(VerifTab) Then Exit Sub
    '---
 
 
    'Boucle pour lire le contenu du tableau.
    'UBound(Tableau, 2) permet de récupérer la limite supérieure de la 2eme dimension
    For i = 1 To UBound(Tableau, 2)
        'Inscrit le résultat dans la fenêtre d'exécution (Ctrl+G)
        Debug.Print Tableau(1, i) & " --> " & Tableau(2, i)
    Next i
End Sub

**munity** · 12/06/2018, 12h29

merci informer

je vais tenter d'appliquer cette soluce et te tiens au courant

david

**informer** · 12/06/2018, 17h18

Merci de cliquer sur le pouce vert des réponses qui t’ont aidé.

Dezipper des fichiers ZIP dans répertoire différent

VBA Access

Discussions similaires

Partager

Partager