Excel 2010 List all Files in a Folder and SubFolder

[Biz]

Dear Sir/Madam,

Application.FileSearch is not supported in Excel 2010.

Option Compare Text
 'The following is a function to call the directory browse window
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
 
Type BrowseInfo
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type
 
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
lpBrowseInfo As BrowseInfo) As Long
 
Function BrowseFolder(Optional Caption As String = "") As String
     
    Dim BrowseInfo As BrowseInfo
    Dim FolderName As String
    Dim ID As Long
    Dim Res As Long
     
    With BrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = Caption
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = 0
    End With
    FolderName = String$(MAX_PATH, vbNullChar)
    ID = SHBrowseForFolderA(BrowseInfo)
    If ID Then
        Res = SHGetPathFromIDListA(ID, FolderName)
        If Res Then
            BrowseFolder = Left$(FolderName, InStr(FolderName, _
            vbNullChar) - 1)
        End If
    End If
     
End Function
 
Sub listfilesinfoldersandsub()
    Dim i               As Long
    Dim Path            As String
    Dim Prompt          As String
    Dim Title           As String
    Dim TempArr() As String
    With Application.FileSearch
         
         'Presently using the BrowseFolder function
         'Comment the following code out to use a fixed path
         'or to look in the path where this workbook resides
        Path = BrowseFolder("Select A Folder")
        If Path = "" Then
            Exit Sub
        Else
            .LookIn = Path
             'If you comment out the preceding code, uncomment one of the
             'following two lines
             '    .LookIn = "F:\Temp\"
             '    .LookIn = ThisWorkbook.Path 'Change to root path
            .FileType = msoFileTypeAllFiles
            .SearchSubFolders = True
            .Execute
             'If you comment out the path code using the function
             'then you will need to comment the following End If also
        End If
        For i = 1 To .FoundFiles.Count
             
            TempArr = Split(.FoundFiles(i), Application.PathSeparator)
            Range("A" & i).Resize(1, UBound(TempArr) + 1) = TempArr
             'comment the two lines above and the Dim TempArr() As String at the beginning of sub
             'and uncomment the line below to use this without putting
             'each directory in a seperate cell
             '    Range("A" & i).Value = .FoundFiles(i)
             
        Next i
    End With
    Columns.AutoFit
End Sub

Could you help me make this code compliant with both Excel 2003 and Excel 2010?

Kind Regards,

Biz

 

[Kyle123]

Indeed, but I'm a fan of the KISS methodology

 

[Biz]

Thanks Kyle, Wigi & Andrew,

I end up using code below

Option Compare Text
 'The following is a function to call the directory browse window
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
 
Type BrowseInfo
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type
 
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
lpBrowseInfo As BrowseInfo) As Long
Function BrowseFolder(Optional Caption As String = "") As String
     
    Dim BrowseInfo As BrowseInfo
    Dim FolderName As String
    Dim ID As Long
    Dim Res As Long
     
    With BrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = Caption
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = 0
    End With
    FolderName = String$(MAX_PATH, vbNullChar)
    ID = SHBrowseForFolderA(BrowseInfo)
    If ID Then
        Res = SHGetPathFromIDListA(ID, FolderName)
        If Res Then
            BrowseFolder = Left$(FolderName, InStr(FolderName, _
            vbNullChar) - 1)
        End If
    End If
     
End Function

Sub test()
Dim Path As String
Dim Files
    Path = BrowseFolder("Select a path")
    Files = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & Path & " /s /b").StdOut.ReadAll, vbLf)
    With Sheet3
    .Columns("A:A").ClearContents
    .Cells(1).Resize(UBound(Files)) = Application.Transpose(Files)
    End With
End Sub

Biz

 

[taurean]

You can do away with API call (UDF: BrowseFolder) if you use a code like this:

Sub test2()
Dim Path As String
Dim objShell As Object 'Shell
Dim Files
    Set objShell = CreateObject("Shell.Application")
    On Error Resume Next
    Path = objShell.BrowseForFolder(0, "Select A Path", 0, "").Self.Path
    On Error GoTo 0
    Files = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & Path & " /s /b").StdOut.ReadAll, vbLf)
    With Sheet3
    .Columns("A:A").ClearContents
    .Cells(1).Resize(UBound(Files)) = Application.Transpose(Files)
    End With
End Sub

 

[wigi]

Hello Taurean

You can do away with your Object variable too

Sub test2()
Dim Path As String
Dim Files
    On Error Resume Next
    Path = CreateObject("Shell.Application").BrowseForFolder(0, "Select A Path", 0, "").Self.Path
    On Error GoTo 0
    Files = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & Path & " /s /b").StdOut.ReadAll, vbLf)
    With Sheet3
    .Columns(1).ClearContents
    .Cells(1).Resize(UBound(Files)) = Application.Transpose(Files)
    End With
End Sub

 

[Peterso]

Glad that I can find this thread. It works perfect but stop when it encounters files with chinese characters. How to solve that? Thanks

 

[taurean]

There are several codes and links posted. Which code are you using e.g. post #12 etc.?

 

[FooYay]

wigi / all,

this code works beautifully, I did have a couple of questions though. Is there an easy way to have it not show directory paths without a file? Example it would show

C:\temp\sample.pdf

but not show

C:\temp

Also, is there an easy way to have it fill column B with the filename without path or extension? IE column B for my above example would show:

sample

Thanks for any help you can provide!

Hello Taurean

You can do away with your Object variable too

Sub test2()
Dim Path As String
Dim Files
    On Error Resume Next
    Path = CreateObject("Shell.Application").BrowseForFolder(0, "Select A Path", 0, "").Self.Path
    On Error GoTo 0
    Files = Split(CreateObject("wscript.shell").Exec("cmd /c dir " & Path & " /s /b").StdOut.ReadAll, vbLf)
    With Sheet3
    .Columns(1).ClearContents
    .Cells(1).Resize(UBound(Files)) = Application.Transpose(Files)
    End With
End Sub