Comment ajouter les attributs des fichiers listés dans les répertoires depuis une racine

**informer** · 19/01/2017, 01h29

Bonjour à tous,

Disons le tout de go, le code a été copié sans vergogne du post de kiki29 lien ici de la discussion Lister les sous-répertoires et les fichiers de ceux-ci .

Petite contribution à la marge, modification du code pour être compatible 64 bits (Cf en fin de post)

Donc merci à tous les participants de cette discussion !!!

Ma question porte sur l'ajout pour chaque fichier des attributs récupérés dans WFD comme suit

Code :

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

1
2
3
Dim WFD As WIN32_FIND_DATA
Dim hFile As LongPtr
    hFile = FindFirstFile(sRoot & ALL_FILES, WFD)

dans la fonction Private Sub SearchForFiles(sRoot As String)

sachant que WIN32_FIND_DATA est déclaré comme une structure (type)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

L'affectation dans une cellule de la feuille se faisant également dans Private Sub SearchForFiles(sRoot As String), j'imaginais tel un béotien, sur la base de la ligne

Code :

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

shDatas.Cells(fp.nCount + RDepart, 2) = sRoot & TrimNull(WFD.cFileName)

ajouter cette ligne

Code :

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

shDatas.Cells(fp.nCount + RDepart, 3) = TrimNull(WFD.ftLastWriteTime)

Déjà pas très intelligent puisque ftLastWriteTime est de type long et qui génère l'erreur

"ByRef argument type mistake"

Alors n'écoutant que...ben je sais pas quoi en fin de compte j'ai essayé directement

Code :

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

shDatas.Cells(fp.nCount + RDepart, 3) = WFD.ftLastWriteTime

Qui génère l'erreur de compilation suivante (in english)

only user defined type in public object module can be coerced to or form a variant or passed to late bound function

alors j'ai essayé

Code :

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

format(CDate(WFD.ftLastWriteTime), "dd/mm/yyyy")

mais là j'ai une erreur de type (type mistake)

Excepté cette ligne ci-dessus, le code modifié 64 bits fonctionne

Code VBA :

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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
Option Explicit
 
Private Const RDepart = 5
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
 
Private Type FILE_PARAMS
    bRecurse As Boolean
    bFindOrExclude As Long
    nCount As Long
    nSearched As Long
    sFileNameExt As String
    sFileRoot As String
End Type
 
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As LongPtr
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function PathMatchSpec Lib "shlwapi" Alias "PathMatchSpecW" (ByVal pszFileParam As LongPtr, ByVal pszSpec As LongPtr) As LongPtr
 
Private fp As FILE_PARAMS
 
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Dim NbDossiers As Long
Dim shDatas As Worksheet
 
 
Sub SelDossierRacine()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Rch .SelectedItems(1)
            NbDossiers = 0
        End If
    End With
End Sub
 
Private Sub Rch(sRacine As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency
 
 
    Set shDatas = Sheets("Sheet1")
    With shDatas
        .Cells.Clear
        .Cells(1, 1) = sRacine
        .Cells(2, 1) = "ALL_FILES"
        .Cells(3, 1) = ""
        .Cells(4, 1) = ""
        .Cells(5, 1) = ""
        .Range("B:B").Clear
    End With
 
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
 
    Application.ScreenUpdating = False
    With fp
        '   start path
        .sFileRoot = QualifyPath(shDatas.Cells(1, 1))
        '   file type(s) of interest
        .sFileNameExt = shDatas.Cells(2, 1)
        .bRecurse = True
        .nCount = 0
        .nSearched = 0
 
        '   0=include, 1=exclude
        .bFindOrExclude = 0
    End With
 
    QueryPerformanceCounter Debut
    SearchForFiles fp.sFileRoot
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    With shDatas
        .Cells(3, 1) = Format$(fp.nSearched, "###,###,###,##0")
        .Cells(4, 1) = "Nbr Dossiers :" & NbDossiers & " // Nbr Fichiers :" & Format$(fp.nCount, "###,###,###,##0")
        .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 2) & " s"
 
        .Range("A1:A5").HorizontalAlignment = xlLeft
        .Range("B2").Select
    End With
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As LongPtr
    hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do
            '   if a folder, and recurse specified, call method again
            If (WFD.dwFileAttributes And vbDirectory) Then
                If Asc(WFD.cFileName) <> vbDot Then
                    NbDossiers = NbDossiers + 1
                    If fp.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
                End If
            Else
                '   must be a file ..
                If MatchSpec(WFD.cFileName, fp.sFileNameExt) Then
                    fp.nCount = fp.nCount + 1
                    shDatas.Cells(fp.nCount + RDepart, 2) = sRoot & TrimNull(WFD.cFileName)
                    ' shDatas.Cells(fp.nCount + RDepart, 3) = Format(CDate(WFD.ftLastWriteTime), "dd/mm/yyyy") ==> en erreur, pourquoi moi commandant cousteau ??????
                End If
            End If
            fp.nSearched = fp.nSearched + 1
        Loop While FindNextFile(hFile, WFD)
        Application.StatusBar = NbDossiers & " / " & fp.nCount
    End If
    FindClose hFile
End Sub
 
Private Function QualifyPath(sPath As String) As String
    If Right$(sPath, 1) <> vbBackslash Then
        QualifyPath = sPath & vbBackslash
    Else
        QualifyPath = sPath
    End If
End Function
 
Private Function TrimNull(startstr As String) As String
    TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function
 
Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
    MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = fp.bFindOrExclude
End Function

Merci par avance et bonjour chez vous

**informer** · 19/01/2017, 09h52

Autres sources avec API WINDOWS

liste d'exemples
Ici un exemple

**kiki29** · 19/01/2017, 15h28

Salut, voir Liste des fichiers d'un dossier : Win 32/64 Bits du 01 Avr 2015

Pour info : 0.741 s pour lister 19322 fichiers

Re, qqs recherches mènent ici, à adapter à ton contexte.

**informer** · 19/01/2017, 20h16

Salut kiki29

Une nouvelle fois, merci pour ton aide. C'est parfait pour ce que j'ai.

Bonjour chez toi

Comment ajouter les attributs des fichiers listés dans les répertoires depuis une racine [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager