capture folder name and file name if folder holds pdf

[jcg]

I want to search a particular file folder that has 5 subfolders (each state) that then has multiple county folders. I want to be able to scan the folders and determine if there is a pdf inside and then return the name of that file and folder to a cell in excel. can someone point me in the right direction? Thanks.

 

[btadams]

Try this:

Sub TestListFiles()
Dim strFolder As String
Dim FileS As FileSearch
Dim F As Variant
Dim x As Integer

    strFolder = GetFolder()
    Set FileS = Application.FileSearch
    With FileS
       .NewSearch
       .Filename = "*.pdf"
       .LookIn = strFolder
       .SearchSubFolders = True
       .Execute
    End With
    Application.ScreenUpdating = False
    Workbooks.Add ' create a new workbook for the folder list

    x = 2
    For Each F In Application.FileSearch.FoundFiles
       Cells(x, 1) = F
       x = x + 1
    Next F

     Application.ScreenUpdating = True
End Sub


Function GetFolder()
Dim sDir As String
Dim objFolder As Object

    On Error GoTo errorhandler
    '// Selects the Root PC Dir!
    Set objFolder = CreateObject("Shell.Application"). _
            BrowseForFolder(0, "Please Select Folder", 0, 0)
    
    If Not objFolder Is Nothing Then
        '// Is it the Root Dir?...if so change
        If Len(objFolder.Items.Item.Path) > 3 Then
            sDir = objFolder.Items.Item.Path & Application.PathSeparator
        Else
            sDir = objFolder.Items.Item.Path
        End If
    End If
    Set objFolder = Nothing  'release object from memory
    If Len(sDir) = 0 Then Exit Function
    GetFolder = sDir
errorhandler:

End Function

 

[jcg]

Thank you so much for your effort on this!!!

When I run the script I get an "Run-time Error 445 Object does not support this action" at the Set FileS = Application.FileSearch line of code.

Thanks again for your help

 

[btadams]

I'm not sure what that error might be. What version of Excel are you running and what OS do you have?

 

[jcg]

I am using office 2007 on windows XP

 

[btadams]

I just did a google search on Excel FileSearch and found that, SURPRISE!, Excel 2007 no longer supports the FileSearch property . There must be a workaround. I'll do some more searching. I'm sure someone on this board has stumbled across this by now.

 

[btadams]

Here's a workaround that I adapted from a post by Nate Oliver. After pasting the code into a standard module you may need to set a reference to the Microsoft Scripting Runtime library (go to the Tools menu and choose References) :

Sub ListFiles()
Dim fso As Object
Dim strName As String, strDir As String
Dim strArr(1 To 65536, 1 To 1) As String, i As Long

strDir = GetFolder()

Let strName = Dir$(strDir & "\*" & ".pdf")
Do While strName <> vbNullString
    Let i = i + 1
    Let strArr(i, 1) = strDir & "\" & strName
    Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)
Set fso = Nothing
Workbooks.Add
If i > 0 Then
    Range("A1").Resize(i).Value = strArr
End If
End Sub

Private Sub recurseSubFolders(ByRef Folder As Object, _
    ByRef strArr() As String, _
    ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
    Let strName = Dir$(SubFolder.Path & "\*" & ".pdf")
    Do While strName <> vbNullString
        Let i = i + 1
        Let strArr(i, 1) = SubFolder.Path & "\" & strName
        Let strName = Dir$()
    Loop
    Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub

Function GetFolder()
Dim sDir As String
Dim objFolder As Object

    On Error GoTo errorhandler
    '// Selects the Root PC Dir!
    Set objFolder = CreateObject("Shell.Application"). _
            BrowseForFolder(0, "Please Select Folder", 0, 0)
    
    If Not objFolder Is Nothing Then
        '// Is it the Root Dir?...if so change
        If Len(objFolder.Items.Item.Path) > 3 Then
            sDir = objFolder.Items.Item.Path & Application.PathSeparator
        Else
            sDir = objFolder.Items.Item.Path
        End If
    End If
    
    Set objFolder = Nothing  'release object from memory
    If Len(sDir) = 0 Then Exit Function
    GetFolder = sDir
errorhandler:

End Function

 

[NateO]

Here's a workaround that I adapted from a post by Nate Oliver. After pasting the code into a standard module you may need to set a reference to the Microsoft Scripting Runtime library (go to the Tools menu and choose References) :

Quick FYI, you won't need a reference, it's using Late Binding.

 

[LxQ]

When I run this report it stops where it reaches a folder where access is denied. Is it too complicated to code it to skip those folders and continue the list and not just quit?