Liste des fichiers du répertoire racine et des sous répertoire après dézippage
par
, 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
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
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 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 '------------------------------------------------------------------------------------------------------------------- '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 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 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
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
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