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 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335
| Option Explicit
'M O N T O R 15/08/2010
'Fonctions API basiques pour la recherche des fichiers
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Boolean
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
'Utiliser à la place de InStr...InStr ne valide pas correctement toutes les occurences
Private Declare Function StrStrI Lib "Shell32" Alias "StrStrIA" _
(ByVal lpFirst As Any, ByVal lpSrch As Any) As Long
Private Const SIZE_MULTIPLIER = 2 ^ 32
Private Const MAX_PATH = 260
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
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 fHandle As Long
Private fFileData As WIN32_FIND_DATA
Private fRoots As Collection
Private fFolders As Collection 'Liste des dossiers visés par la recherche
Private fFilters() As String '
Private fCalculated As Long '
Private fCount As Long '
Private fFilename As String 'Nom de l'actual fichier ou dossier
Private fIndex As Long
Private fSubFolders As Boolean 'Inclure une recherche dans les sous dossiers
Private fOpened As Boolean 'une recherche est ouverte par FindFirstFile
Private fTerminated As Boolean 'Recherche temintée
Private Sub Class_Initialize()
Set fFolders = New Collection
Set fRoots = New Collection
ReDim fFilters(0)
End Sub
Private Sub Class_Terminate()
Clear
Set fFolders = Nothing
Set fRoots = Nothing
ReDim fFilters(0)
ResetSearch
End Sub
Private Function MoveNext() As Boolean
'Declacer la recherche dans le dossier suivant sur la liste
MoveNext = False
If (fFolders.Count > 0) And (fFolders.Count > fIndex) Then
fIndex = fIndex + 1
MoveNext = True
End If
End Function
Private Function InternalFindFirst() As Boolean
'Trouve la premiere occurence sur un nom de fichier
InternalFindFirst = False
If fOpened Then
FindClose (fHandle)
End If
While MoveNext()
fFileData.cFileName = Space$(MAX_PATH)
fHandle = FindFirstFile(fFolders(fIndex) & "*", fFileData)
If fHandle <> -1 Then
Do
If IsValidFilename Then
InternalFindFirst = True
Exit Function
End If
Loop Until Not FindNextFile(fHandle, fFileData)
FindClose (fHandle)
End If
Wend
End Function
Private Function InternalFindNext() As Boolean
Dim ret As Boolean
InternalFindNext = False
If Not IsActive Then Exit Function
fFileData.cFileName = Space$(MAX_PATH)
While FindNextFile(fHandle, fFileData)
If IsValidFilename Then
InternalFindNext = True
Exit Function
End If
Wend
FindClose (fHandle)
End Function
Private Function MutchAttr(Attrib As Long) As Boolean
'teste l'existance d'une attribute
MutchAttr = (fFileData.dwFileAttributes And Attrib) = Attrib
End Function
Public Function GetCount() As Long
'Faire une simulation de recherche pour retourer le nombre de fichiers trouvés
GetCount = fCount
If fCalculated Then Exit Function
ClearSearch
While Gets
fCount = fCount + 1
Wend
ResetSearch
fCalculated = True
GetCount = fCount
End Function
Public Sub AddRoot(ADir As String)
'Ajouter un nouveau dossier à la liste
If IsActive Then Exit Sub
If Right(ADir, 1) <> "\" Then
ADir = ADir & "\"
End If
On Error Resume Next
fRoots.Add$ ADir, CStr(ADir)
AddFolder (ADir)
End Sub
Private Sub AddFolder(ADir As String)
'Ajouter un nouveau sous dossier à la liste
If Right(ADir, 1) <> "\" Then
ADir = ADir & "\"
End If
On Error Resume Next
fFolders.Add$ ADir, CStr(ADir)
End Sub
Public Function Gets() As Boolean
'Renvoie les occuences touvées par InternalFindFirst et InternalFindNext
Gets = False
If fTerminated Then Exit Function
Do
If Not fOpened Then
fOpened = InternalFindFirst()
Else
fOpened = InternalFindNext()
End If
If fOpened Then
Gets = True
Exit Function
End If
Loop Until fIndex = fFolders.Count
fTerminated = True
End Function
Private Function IsActive()
'Une recherche est ouverte
IsActive = fOpened And Not fTerminated
End Function
Private Function IsValidFilename() As Boolean
'Valider le nom trouvé
Dim I As Long
IsValidFilename = False
With fFileData
fFilename = Left(.cFileName, InStr(.cFileName, vbNullChar) - 1)
End With
If AttrDirectory Then
If fFilename = "." Or fFilename = ".." Then
Exit Function
End If
If fSubFolders And Not fCalculated Then
AddFolder (fFolders(fIndex) & fFilename)
End If
End If
If UBound(fFilters) = 0 Then
IsValidFilename = True
Exit Function
End If
For I = 1 To UBound(fFilters)
If StrStrI(fFilename, fFilters(I)) <> 0 Then
IsValidFilename = True
Exit Function
End If
Next
End Function
Private Sub ClearSearch()
'Efface la liste des doussiers filtres pour effectuer une nouvelle recherche
Dim V As Variant
Set fFolders = Nothing
Set fFolders = New Collection
ResetSearch
fCalculated = 0
fCount = 0
For Each V In fRoots
fFolders.Add V, CStr(V)
Next
End Sub
Private Sub ResetSearch()
'Efface la liste des doussiers filtres pour effectuer une nouvelle recherche
If fOpened Then
FindClose (fHandle)
End If
fOpened = False
fTerminated = False
fIndex = 0
End Sub
Public Sub Clear()
'Efface la liste des doussiers filtres pour effectuer une nouvelle recherche
Set fRoots = Nothing
Set fRoots = New Collection
ReDim fFilters(0)
fSubFolders = False
ClearSearch
End Sub
Public Function GetFilePath(Optional aFilname As String = "") As String
'Renvoie le chemain pour le fichier actuel
If IsActive() Then
GetFilePath = fFolders(fIndex) & aFilname
End If
End Function
Public Function GetFilename(Optional StripeExt As Boolean = False) As String
Dim P As Long
If StripeExt And Not AttrDirectory Then
P = InStrRev(fFilename, ".")
If P <> 0 Then
GetFilename = Left(fFilename, P - 1)
End If
Else
GetFilename = fFilename
End If
End Function
Public Sub ExportFolders(aCollection As Collection)
'Exporte la liste des doussiers ou la recherche à été effectuée
Dim N As Variant
If aCollection Is Nothing Then
Set aCollection = New Collection
End If
For Each N In fFolders
aCollection.Add (N)
Next
End Sub
Public Property Get AttrReadOnly() As Boolean
AttrReadOnly = MutchAttr(FILE_ATTRIBUTE_READONLY)
End Property
Public Property Get AttrHidden() As Boolean
AttrHidden = MutchAttr(FILE_ATTRIBUTE_HIDDEN)
End Property
Public Property Get AttrSystem() As Boolean
AttrReadOnly = MutchAttr(FILE_ATTRIBUTE_SYSTEM)
End Property
Public Property Get AttrDirectory() As Boolean
AttrDirectory = MutchAttr(FILE_ATTRIBUTE_DIRECTORY)
End Property
Public Property Let LookInSubFolders(Value As Boolean)
If Value <> fSubFolders Then
ClearSearch
fSubFolders = Value
End If
End Property
Public Property Get LookInSubFolders() As Boolean
LookInSubFolders = fSubFolders
End Property
Public Property Get FileSize() As Currency
FileSize = fFileData.nFileSizeLow + fFileData.nFileSizeHigh * SIZE_MULTIPLIER
End Property
Public Property Get Filter() As String
Filter = Join(fFilters, ";")
End Property
Public Property Let Filter(Value As String)
'filtres utiliser pour valider les noms des fichiers délimités par ";"
'Ex:.jpg;.gif;dossier1
Dim C As Collection
Dim I As Long, F() As String
If IsActive() Then Exit Property
ClearSearch
F = Split(Value, ";")
Set C = New Collection
'Supprime les doublons
For I = LBound(F) To UBound(F)
On Error Resume Next
C.Add F(I), F(I)
On Error GoTo 0
Next
ReDim fFilters(C.Count)
For I = 1 To C.Count
fFilters(I) = C(I)
Next
Set C = Nothing
End Property |
Partager