Scan subfolders for PDF files and count pages

**ISMI** · 10-03-2018, 03:23 AM

Dear Friends,

I found this code for scanning of folder for PDF files, counting number of pages and exporting of result to worksheet.

Sub PDFandNumPages()
   
   Dim Folder As Object
   Dim file As Object
   Dim fso As Object
   Dim iExtLen As Integer, iRow As Integer
   Dim sFolder As String, sExt As String
   Dim sPDFName As String

   sExt = "pdf"
   iExtLen = Len(sExt)
   iRow = 2
   ' Must have a '\' at the end of path
   sFolder = "C:\Users\ismi\Desktop\14_Editable_Copy_18SEP\"
   
   Set fso = CreateObject("Scripting.FileSystemObject")
   
   If sFolder <> "" Then
      Set Folder = fso.GetFolder(sFolder)
      For Each file In Folder.files
         If Right(file, iExtLen) = sExt Then
            Cells(iRow, 1).Value = file.Name
            Cells(iRow, 2).Value = pageCount(sFolder & file.Name)
            iRow = iRow + 1
         End If
      Next file
   End If

End Sub
Function pageCount(sFilePathName As String) As Integer

Dim nFileNum As Integer
Dim sInput As String
Dim sNumPages As String
Dim iPosN1 As Integer, iPosN2 As Integer
Dim iPosCount1 As Integer, iPosCount2 As Integer
Dim iEndsearch As Integer

' Get an available file number from the system
nFileNum = FreeFile

'OPEN the PDF file in Binary mode
Open sFilePathName For Binary Lock Read Write As #nFileNum
  
  ' Get the data from the file
  Do Until EOF(nFileNum)
      Input #1, sInput
      sInput = UCase(sInput)
      iPosN1 = InStr(1, sInput, "/N ") + 3
      iPosN2 = InStr(iPosN1, sInput, "/")
      iPosCount1 = InStr(1, sInput, "/COUNT ") + 7
      iPosCount2 = InStr(iPosCount1, sInput, "/")
      
   If iPosN1 > 3 Then
      sNumPages = Mid(sInput, iPosN1, iPosN2 - iPosN1)
      Exit Do
   ElseIf iPosCount1 > 7 Then
      sNumPages = Mid(sInput, iPosCount1, iPosCount2 - iPosCount1)
      Exit Do
   ' Prevent overflow and assigns 0 to number of pages if strings are not in binary
   ElseIf iEndsearch > 1001 Then
      sNumPages = "0"
      Exit Do
   End If
      iEndsearch = iEndsearch + 1
   Loop
   
  ' Close pdf file
  Close #nFileNum
  pageCount = CInt(sNumPages)
  
End Function

I found that this code does not find the PDF files that stored in subfolders. Also I need to define needed path via "Dialog window".

Please help me to solve this problem, because this macro is very necessary for my work.

Thanks and have a nice day

**WideBoyDixon** · 10-03-2018, 05:17 AM

Give this a try in a new module:

Private RegExp As Object
Private FSO As Object
Private nextRow As Long
Public Sub OutputPdfAndPages()
   
Dim rootFolderPath As String
Dim folderPicker As FileDialog

Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With folderPicker
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Environ("UserProfile")
    If .Show <> -1 Then Exit Sub
    rootFolderPath = .SelectedItems(1)
End With

Set FSO = CreateObject("Scripting.FileSystemObject")
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
nextRow = 2

ScanFolderForPdf rootFolderPath

End Sub
Public Sub ScanFolderForPdf(thisFolderPath As String)

Dim thisfolder As Object
Dim subFolder As Object
Dim folderFile As Object

Set thisfolder = FSO.GetFolder(thisFolderPath)
For Each subFolder In thisfolder.SubFolders
    ScanFolderForPdf subFolder.Path
Next subFolder

For Each folderFile In thisfolder.Files
    If StrComp(Right(folderFile.Path, 4), ".pdf", vbTextCompare) = 0 Then
        Cells(nextRow, "A").Value = folderFile.Path
        Cells(nextRow, "B").Value = GetPdfPageCount(folderFile.Path)
        nextRow = nextRow + 1
    End If
Next folderFile

End Sub
Public Function GetPdfPageCount(filePath) As Long

Dim fh As Integer
Dim fileContents As String

fh = FreeFile
Open filePath For Binary Lock Read Write As #fh
fileContents = Space(LOF(fh))
Get #fh, , fileContents
Close #fh

GetPdfPageCount = RegExp.Execute(fileContents).Count

End Function

WBD

**ISMI** · 10-03-2018, 05:32 AM

WOW, It's works!!!! Thank you. Last question: could you please include in code, that this list will be created in new sheet with name "PDF_List"?

**WideBoyDixon** · 10-03-2018, 05:37 AM

Private RegExp As Object
Private FSO As Object
Private nextRow As Long
Public Sub OutputPdfAndPages()
   
Dim rootFolderPath As String
Dim folderPicker As FileDialog
Dim newWorksheet As Worksheet

Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With folderPicker
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Environ("UserProfile")
    If .Show <> -1 Then Exit Sub
    rootFolderPath = .SelectedItems(1)
End With

Set FSO = CreateObject("Scripting.FileSystemObject")
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
nextRow = 2

On Error Resume Next
Set newWorksheet = Sheets("PDF_List")
If newWorksheet Is Nothing Then
    Set newWorksheet = Sheets.Add(After:=Sheets(Sheets.Count))
    newWorksheet.Name = "PDF_List"
Else
    newWorksheet.Activate
    newWorksheet.Cells.ClearContents
End If

ScanFolderForPdf rootFolderPath

End Sub
Public Sub ScanFolderForPdf(thisFolderPath As String)

Dim thisfolder As Object
Dim subFolder As Object
Dim folderFile As Object

Set thisfolder = FSO.GetFolder(thisFolderPath)
For Each subFolder In thisfolder.SubFolders
    ScanFolderForPdf subFolder.Path
Next subFolder

For Each folderFile In thisfolder.Files
    If StrComp(Right(folderFile.Path, 4), ".pdf", vbTextCompare) = 0 Then
        Cells(nextRow, "A").Value = folderFile.Path
        Cells(nextRow, "B").Value = GetPdfPageCount(folderFile.Path)
        nextRow = nextRow + 1
    End If
Next folderFile

End Sub
Public Function GetPdfPageCount(filePath) As Long

Dim fh As Integer
Dim fileContents As String

fh = FreeFile
Open filePath For Binary Lock Read Write As #fh
fileContents = Space(LOF(fh))
Get #fh, , fileContents
Close #fh

GetPdfPageCount = RegExp.Execute(fileContents).Count

End Function

WBD

**ISMI** · 10-03-2018, 05:53 AM

It's works...Sorry last addition from my side: how I can change filepath to file name without *.pdf ? Thank you

**WideBoyDixon** · 10-03-2018, 08:14 AM

Change this line:

        Cells(nextRow, "A").Value = FSO.GetFile(folderFile.Path).ParentFolder.Path & "\" & FSO.GetBaseName(folderFile.Path)

WBD

**YasserKhalil** · 10-03-2018, 09:01 AM

@WBD
Thanks a lot for the code
I have tested it and found incorrect results in the number of the PDF pages count
Example I have a PDF with 17 pages and the result was 21 .. Any idea why?

**WideBoyDixon** · 10-03-2018, 10:33 AM

Originally Posted by YasserKhalil

@WBD
Thanks a lot for the code
I have tested it and found incorrect results in the number of the PDF pages count
Example I have a PDF with 17 pages and the result was 21 .. Any idea why?

There's no reliable method to count pages in a PDF file. The method used above is to find the number of times the "\Page" occurs in the file as this usually signifies a new page. If you open up the PDF in a text editor, you can search for "\Page" yourself (excluding "\Pages") to see how many times that occurs.

WBD

**ISMI** · 10-03-2018, 12:12 PM

Originally Posted by YasserKhalil

@WBD
Thanks a lot for the code
I have tested it and found incorrect results in the number of the PDF pages count
Example I have a PDF with 17 pages and the result was 21 .. Any idea why?

I have the same issue, when in one document you have A4 and A3 pages. The same story for A0 and A1 format. Anyway WBD helps me very much.

**YasserKhalil** · 10-03-2018, 10:59 AM

But using acrobat pro gives correct number of pages

Function GetPDFPageCount(filePath) As Long
    Dim acroDoc As Object

    Set acroDoc = New AcroPDDoc
    acroDoc.Open filePath

    GetPDFPageCount = acroDoc.GetNumPages
    acroDoc.Close
End Function

**WideBoyDixon** · 10-03-2018, 11:29 AM

Great! Then use that. If the OP is happy to spend £160 on some software, it's a great solution.

WBD

**mohan.r1980** · 10-04-2018, 10:11 AM

Originally Posted by YasserKhalil

But using acrobat pro gives correct number of pages

Function GetPDFPageCount(filePath) As Long
    Dim acroDoc As Object

    Set acroDoc = New AcroPDDoc
    acroDoc.Open filePath

    GetPDFPageCount = acroDoc.GetNumPages
    acroDoc.Close
End Function

hi Yasser,
request you post full code here and also tell me which reference should i apply from tools menu.

**YasserKhalil** · 10-03-2018, 11:32 AM

The post just in case the OP has already the acrobat Pro and absolutely won't buy for that task !!

**ISMI** · 10-03-2018, 11:58 AM

Awesome, WBD! It is works

Shake your hand

**YasserKhalil** · 10-03-2018, 12:15 PM

Great. Glad it worked for you and thanks a lot for WBD for his great solution

**WideBoyDixon** · 10-04-2018, 05:44 AM

Just one more thing on this. I did find this library:

https://www.debenu.com/products/deve...ary-lite/free/

Using this, I managed to create an implementation of a page count function that works reliably. If anyone's interested.

WBD

**YasserKhalil** · 10-04-2018, 05:53 AM

That's great WBD. I will appreciate if you share it

**WideBoyDixon** · 10-04-2018, 06:37 AM

The the library installed and registered:

Private FSO As Object
Private PdfLib As Object
Private nextRow As Long
Public Sub OutputPdfAndPages()
   
Dim rootFolderPath As String
Dim folderPicker As FileDialog
Dim newWorksheet As Worksheet

Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With folderPicker
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Environ("UserProfile")
    If .Show <> -1 Then Exit Sub
    rootFolderPath = .SelectedItems(1)
End With

Set FSO = CreateObject("Scripting.FileSystemObject")
Set PdfLib = CreateObject("DebenuPDFLibraryLite.PDFLibrary")
nextRow = 2

On Error Resume Next
Set newWorksheet = Sheets("PDF_List")
If newWorksheet Is Nothing Then
    Set newWorksheet = Sheets.Add(After:=Sheets(Sheets.Count))
    newWorksheet.Name = "PDF_List"
Else
    newWorksheet.Activate
    newWorksheet.Cells.ClearContents
End If

ScanFolderForPdf rootFolderPath

End Sub
Public Sub ScanFolderForPdf(thisFolderPath As String)

Dim thisfolder As Object
Dim subFolder As Object
Dim folderFile As Object

Set thisfolder = FSO.GetFolder(thisFolderPath)
For Each subFolder In thisfolder.SubFolders
    ScanFolderForPdf subFolder.Path
Next subFolder

For Each folderFile In thisfolder.Files
    If StrComp(Right(folderFile.Path, 4), ".pdf", vbTextCompare) = 0 Then
        Cells(nextRow, "A").Value = FSO.GetFileName(folderFile.Path)
        Cells(nextRow, "B").Value = GetPdfPageCount(folderFile.Path)
        nextRow = nextRow + 1
    End If
Next folderFile

End Sub
Public Function GetPdfPageCount(filePath) As Long

PdfLib.LoadFromFile filePath, ""
GetPdfPageCount = PdfLib.PageCount

End Function

WBD

**YasserKhalil** · 10-04-2018, 06:48 AM

When trying to download I have entered my email but I got this message
Please enter your business email address. This form does not accept addresses from gmail.com.

And I have no business email address !!

**WideBoyDixon** · 10-04-2018, 06:52 AM

Try this:

https://we.tl/t-WEN3EgYdZa

WBD

**YasserKhalil** · 10-04-2018, 07:24 AM

Thank you very much

After installing it I have searched Reference for Debenu but didn't find so I tried to browse the dll file
But I don't know which one is the correct dll
Untitled.png

**WideBoyDixon** · 10-04-2018, 07:29 AM

Read the GettingStarted.pdf that resides in the installation folder. It tells you how to register the DLL. If you're using 32-bit Office, register the 32-bit DLL. If you're running 64-bit Office then register the 64-bit DLL. Or try both.

WBD

**YasserKhalil** · 10-04-2018, 07:38 AM

Thanks a lot for guiding me
Now I have registered it and it appears in References and also I have tested that code to make sure everything is OK

Sub Test()
    Dim PDFLibrary As DebenuPDFLibraryLite1114.PDFLibrary
    Set PDFLibrary = CreateObject("DebenuPDFLibraryLite1114.PDFLibrary")
    Call PDFLibrary.DrawText(100, 500, "Hello from Visual Basic")
    Call PDFLibrary.SaveToFile(ThisWorkbook.Path & "\HelloFromVB.pdf")
    Set PDFLibrary = Nothing
End Sub

But when testing your last code I got the worksheet PDF_List but empty with no results .. Any idea?

**YasserKhalil** · 10-04-2018, 07:48 AM

After debugging the code I have found this missing line

nextRow = 2

On Error Resume Next
Set newWorksheet = Sheets("PDF_List")

Now it is perfect

Thanks a lot for sharing your awesome solution WBD

**YasserKhalil** · 10-04-2018, 10:13 AM

You have to install Acrobat Pro (it is not free)
And from References you have to select "Acrobat"

Hybrid View

Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Re: Scan subfolders for PDF files and count pages

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] list of subfolders in folder - without files and sub-subfolders

[SOLVED] Count Files in a folder and subfolders, with specific name

[SOLVED] Files within Multiple SubFolders and SubFolders Within It

[SOLVED] copy subfolders, replace text in files and save files in copied subfolders

Bookmarks

Bookmarks

Posting Permissions