informer

Liste des fichiers du répertoire racine et des sous répertoire après dézippage

Noter ce billet

0 Commentaires

par

informer

, 18/02/2021 à 18h12 (1045 Affichages)

Je partage

Pré-requis:

Le répertoire source (vRepSource) contenant les fichiers Zip est sélectionné via une boite de dialogue (Application.FileDialog(msoFileDialogFolderPicker)
Le répertoire cible dans lequel sont décompressés les fichiers Zip (vRepCible) écrit en dur
Le niveau d'arborescence provoque un décalage de colonne
Les données sont ensuite copiées dans un autre fichier pour les afficher dans un treeView
Le traitement est lancé sur l'événement click d'un bouton ActiveX

Code:

De lancement

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
Private Sub CommandButton1_Click()

    Dim vRepSource As Variant, vRepCible As Variant
    Dim iResult As Integer
    
    iResult = MsgBox("Dézipper?", vbQuestion + vbYesNo)
    If iResult = 6 Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = "C:\_Paul\Apparts\6CBresson\Drive\Versions" 'use the default folder path here
            .Title = "Sélectionner le répertoire source "
            .Show
            vRepSource = .SelectedItems(1) & "\"
            
        End With
        
        vRepCible = "C:\Drive\UnZip\" ' A modifier en dur ou remonter dans le FileDialog
        
        Call fDelAllInFolder(vRepCible)
        Call fUnZipFile(vRepSource, vRepCible)
        
    End If

    ActiveSheet.Cells.ClearContents
    
    lLigne = 0
    lNiv = 0
    Call fListArboMain(vRepCible)
    Call fPastValueToTreeView
    
    MsgBox "Fin traitement"
    
End Sub

De suppression des items du répertoire cible

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
'-------------------------------------------------------------------------------------------------------------------
'Delete all files and subfolders
'-------------------------------------------------------------------------------------------------------------------
Sub fDelAllInFolder(vRepCible As Variant)

    'Be sure that no file is open in the folder
    Dim FSO As Object

    Set FSO = CreateObject("scripting.filesystemobject")

    If Right(vRepCible, 1) = "\" Then
        vRepCible = Left(vRepCible, Len(vRepCible) - 1)
    End If

    If FSO.FolderExists(vRepCible) = False Then
        MsgBox vRepCible & " doesn't exist"
        Exit Sub
    End If

    On Error Resume Next
   
    FSO.deletefile vRepCible & "\*.*", True  ' Delete files
    FSO.deletefolder vRepCible & "\*.*", True ' Delete subfolders
   
   On Error GoTo 0

End Sub

De décompression

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
Sub fUnZipFile(vRepSource As Variant, vRepCible As Variant)
    
    Dim Value As String, Folders() As String
    Dim Folder As Variant, vItem As Variant
    Dim a As Long
    Dim oApp As Object
     
    ReDim Folders(0)
     
    If Right(vRepSource, 2) = "\\" Then Exit Sub
    Value = Dir(vRepSource, &H1F)
     
    Do Until Value = ""
        If Value = "." Or Value = ".." Then
        Else
            If GetAttr(vRepSource & Value) = 16 Or GetAttr(vRepSource & Value) = 48 Then
                Folders(UBound(Folders)) = Value
                ReDim Preserve Folders(UBound(Folders) + 1)
            Else
                If Right(Value, 4) = ".zip" Then
                    Set oApp = CreateObject("Shell.Application")
                    oApp.Namespace(vRepCible).CopyHere oApp.Namespace(vRepSource & Value).items
                End If
            End If
        End If
        Value = Dir
    Loop
     
    For Each Folder In Folders
        Call fUnZipFile(vRepSource & Folder & "\", vRepCible)
    Next Folder
 
End Sub

De parcours de l'arborescence

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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Sub fListArboMain(vRepCible As Variant)

    ' Attention, les variables sont déclaré en type variant puisque la syntaxe vient d'un VBS.
    Dim oFS As Variant, oLecteur As Variant, oFolder As Variant, oSubFolder As Variant
    Dim Boucle As Variant
    Dim sPahtFileCible As String
    
    On Error Resume Next

    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set oLecteur = oFS.GetDrive("C")

    
    If (oLecteur.IsReady) Then
        Set oFolder = oFS.GetFolder(vRepCible)
        If oFolder.Name <> "" Then
            lLigne = lLigne + 1
            lNiv = lNiv + 1
            ActiveSheet.Cells(lLigne, lNiv) = oFolder.Name
            
            'Liste les fichiers du répertoire racine
            If (oLecteur.RootFolder.Files.Count > 0) Then
                 lNiv = lNiv + 1
                 For Each oFichier In oLecteur.RootFolder.Files
                    lLigne = lLigne + 1
                    ActiveSheet.Cells(lLigne, lNiv) = oFichier.Name
                Next
            End If
        
            'Parcours les sous-répertoires depuis répertoire racine -> ' Routine récursive
            For Each oSubFolder In oFolder.SubFolders
                 Call ListeFichier(oSubFolder)
            Next
        End If
    End If

End Sub

Sub ListeFichier(ByVal oFolder As Variant)

    Dim oSubFolder As Variant, oFichier As Variant

    On Error Resume Next

    lLigne = lLigne + 1
    
    ActiveSheet.Cells(lLigne, lNiv) = oFolder.Name
    
    lNiv = lNiv + 1
    
    If (oFolder.Files.Count > 0) Then
        For Each oFichier In oFolder.Files
            lLigne = lLigne + 1
            
            ActiveSheet.Cells(lLigne, lNiv) = oFichier.Name
        Next
    End If

    ' Routine récursive
    If (oFolder.SubFolders.Count > 0) Then
        For Each oSubFolder In oFolder.SubFolders
            Call ListeFichier(oSubFolder)
        Next
    End If
        
    lNiv = lNiv - 1
End Sub


Sub fUnZipFile(vRepSource As Variant, vRepCible As Variant)
    
    Dim Value As String, Folders() As String
    Dim Folder As Variant, vItem As Variant
    Dim a As Long
    Dim oApp As Object
     
    ReDim Folders(0)
     
    If Right(vRepSource, 2) = "\\" Then Exit Sub
    Value = Dir(vRepSource, &H1F)
     
    Do Until Value = ""
        If Value = "." Or Value = ".." Then
        Else
            If GetAttr(vRepSource & Value) = 16 Or GetAttr(vRepSource & Value) = 48 Then
                Folders(UBound(Folders)) = Value
                ReDim Preserve Folders(UBound(Folders) + 1)
            Else
                If Right(Value, 4) = ".zip" Then
                    Set oApp = CreateObject("Shell.Application")
                    oApp.Namespace(vRepCible).CopyHere oApp.Namespace(vRepSource & Value).items
                End If
            End If
        End If
        Value = Dir
    Loop
     
    For Each Folder In Folders
        Call fUnZipFile(vRepSource & Folder & "\", vRepCible)
    Next Folder
 
End Sub

De copie de l'arborescence dans un fichier cible pour affichage dans un treeView

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
Sub fPastValueToTreeView()
    'Find the last used row in both sheets and copy and paste data below existing data.

    Dim oWkCible As Workbook, oShtCible As Worksheet
    Dim oRg As Range
    Dim sPathFile As String
    Dim lCopyLastRow As Long, lDestLastRow As Long
     
    
    sPathFile = "C:\Drive\TreeView\Drive_TreeView.xls"
    
    Set oRg = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
    
    Set oWkCible = Workbooks.Open(Filename:=sPathFile)
    Set oShtCible = oWkCible.Worksheets(2)
    
    oShtCible.Activate
    oShtCible.Cells.ClearContents
    
    Debug.Print oRg.Rows.Count & " - " & oRg.Columns.Count
    
    oRg.Copy
    
    oShtCible.Range(oShtCible.Cells(1, 2), oShtCible.Cells(oRg.Rows.Count, oRg.Columns.Count)).PasteSpecial xlPasteValues
    oWkCible.Close SaveChanges:=True
    
    
    Set oRg = Nothing
    Set oShtCible = Nothing
    Set oWkCible = Nothing
 
End Sub