Menu

VBA-VB6 - Read all directories files

USESFRBR



The Scripting.FileSystemObject function replaces Application.FileSearch which is no longer available as from Office 2007
An example on how to store all the image files to a directory.

Paste in a module: 

Option Explicit   
Dim Data()   
Dim NBdata As Integer   

'Optenir tout les fichiers d'un répertoir et éventuellement des sous-répertoirs   
'Si SousRep = true   
'Le répertoir source doit être dans Rep   
Public Function LireRepertoir(ByVal Rep As String, Optional SousRep As Boolean) As Integer   
Dim Obj, RepP, F, S, sf, F1, Fsous   
Dim i As Integer, Ext As String   
Dim Chem As String   
Dim T As Double   
   ' Application.MousePointer = 13 'Pour VB6  
    Set Obj = CreateObject("Scripting.FileSystemObject")   
    Set RepP = Obj.Getfolder(Rep)   
    Chem = Rep: If Right(Chem, 1) <> "\" Then Chem = Chem & "\"   
       
    Set sf = RepP.subfolders   
    Set F = RepP.Files   
    GoSub RempliData 'les fichiers du répertoir principal   
    If SousRep Then 'les fichiers des sous-répertoirs   
        For Each Fsous In sf   
            Set RepP = Fsous   
            Set F = RepP.Files   
            GoSub RempliData   
        Next Fsous   
    End If   
Exit Function   
'**********************************************************************   
RempliData:   
    For Each F1 In F   
        Ext = LCase(Right(F1.Name, 3))   
        If Ext = "bmp" Or Ext = "jpg" Then 'extention à adapter   
            ReDim Preserve Data(5, NBdata)   
            Data(0, NBdata) = F1.Name   
            Data(1, NBdata) = F1.ParentFolder & "\" & F1.Name   
            Data(2, NBdata) = F1.DateCreated   
            Data(3, NBdata) = F1.DateLastAccessed   
            Data(4, NBdata) = F1.DateLastModified   
            T = F1.Size   
            If T < 99999 Then   
                Data(5, NBdata) = T & " Bi"   
            ElseIf T < 999999 Then   
                Data(5, NBdata) = Round(T / 1000, 1) & " Ko"   
            Else   
                Data(5, NBdata) = Round(T / 1000000, 1) & " Mo"   
            End If   
            NBdata = NBdata + 1   
        End If   
    Next F1   
Return   
       
End Function
Outlook - Receiving same e-mail 100 times
Special characters: AZERTY Keyboard shortcut