how to Search Sub Folders - Help Please

[Johnny2000]

Hi,

I a newbie to VBA and not got much further than creating userforms (but totally addicted) and i am desperate for some help.

I have some code below which i need modded to search sub folders as well.

Can someone pleae help me and it is greatly appreciated. At least advise if it is possible or not.

I dont know if it needs a varible declared or how to get it to search sub folders.

i have tried subfolder = true etc..

Sub PDFPageNumbers()
Dim FSO As Object
Dim F_Folder As Object
Dim F_File As Object
Dim Selected_Items As String
Dim DialogFolder As FileDialog
Dim Acrobat_File As Acrobat.AcroPDDoc
Dim i As Long

'Select PDF Directory
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
If DialogFolder.Show = -1 Then
Selected_Items = DialogFolder.SelectedItems(1)
Else: Set DialogFolder = Nothing
End If
Set DialogFolder = Nothing
Set FSO = CreateObject("Scripting.FileSystemObject")
Set F_Folder = FSO.getfolder(Selected_Items)
i = 2
Filecount = F_Folder.Files.Count
For Each F_File In F_Folder.Files
Selected_Items = UCase(F_File.Path)
If Right(Selected_Items, 4) = ".PDF" Then
Set Acrobat_File = New Acrobat.AcroPDDoc
Acrobat_File.Open Selected_Items
Cells(i, 1).Value = Selected_Items
Cells(i, 2).Value = Acrobat_File.GetNumPages
i = i + 1
Acrobat_File.Close
Set Acrobat_File = Nothing
End If
Application.StatusBar = "Completed " & Application.Text((i - 2) / Filecount, "0.00%")
Next
Application.StatusBar = False
Range("A:B").Columns.AutoFit
Set F_File = Nothing
Set F_Folder = Nothing
Set FSO = Nothing
End Sub

 

[mvsub1]

Hello Johnny2000,

probably there are other ways as well, but I believe this should work for you:

Sub PDFPageNumbers()
    Dim FSO As Object
    Dim F_Folder As Object
    Dim F_File As Object
    Dim Selected_Items As String
    Dim DialogFolder As FileDialog
    Dim Acrobat_File As Acrobat.AcroPDDoc
    Dim i As Long
    
    Dim colFiles As New Collection
    Dim strFolder As String
    Dim vFile As Variant
    
    'Select PDF Directory
    Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    If DialogFolder.Show = -1 Then
        Selected_Items = DialogFolder.SelectedItems(1)
        Else: Set DialogFolder = Nothing
    End If
    
    Set DialogFolder = Nothing
    
    RecursiveDir colFiles, Selected_Items, "", True
    
    i = 2
    Filecount = colFiles.Count
    
    For Each vFile In colFiles
        vFile = UCase(vFile)
        If Right(vFile, 4) = ".PDF" Then
            Set Acrobat_File = New Acrobat.AcroPDDoc
            Acrobat_File.Open vFile
            Cells(i, 1).Value = vFile
            Cells(i, 2).Value = Acrobat_File.GetNumPages
            i = i + 1
            Acrobat_File.Close
            Set Acrobat_File = Nothing
            Application.StatusBar = "Completed " & Application.Text((i - 2) / Filecount, "0.00%")
        End If
    Next
    
    Application.StatusBar = False
    Range("A:B").Columns.AutoFit
    Set F_File = Nothing
    Set F_Folder = Nothing
    Set FSO = Nothing
End Sub


Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)


    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant


    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop


    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop


        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If


End Function




Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Tested and worked
Always make a copy of your workbook first, before testing any code!

 

[Johnny2000]

MVSUB!! You Rock! Success

Thank you so much. i needed to add Acrobat as a reference again for some reason.

I will test it using F8 so i can try and learn what it is doing. It seems you had to re-write most of it? many thanks and a debt of gratitude.

its a good little tool if you have large amounts of PDF files or OCR conversions needing to be done

Thanks again