vba - Get the number of pages and file names of pdf files using PDFtk and write it to excel

Question

I am new member, i will do my best efforts to be specifc and clear and respect the time of the members.I am a begginer in VBA and need your help.

I am using a free version of the program PDFtk that shows information about pdf files through a graphical interface (you can see the attached picture).

PDFtk

The program show for each pdf file 2 types of information:

1. The file name
2. The number of pages

However, i'm looking for a VBA macro that will retrive that information (file name, number of pages) and then write it to an open workbook in excel.

It's important that the VBA will search for pdf files at specific location in my computer c:emp

and then write to excel somthing like this:

Excel filenames and number of pages

In another words, a need a VBA that can do the job without "really" opening the graphical interface, and yet use the PDFtk application to get the correct number of pages.

Thanks in advance for your help

question from:https://stackoverflow.com/questions/65849341/get-the-number-of-pages-and-file-names-of-pdf-files-using-pdftk-and-write-it-to

Answer 1

Try this (source: link)

Sub Test()
    Dim I As Long
    Dim xRg As Range
    Dim xStr As String
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Dim xFileNum As Long
    Dim RegExp As Object
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
        Set xRg = Range("A1")
        Range("A:B").ClearContents
        Range("A1:B1").Font.Bold = True
        xRg = "File Name"
        xRg.Offset(0, 1) = "Pages"
        I = 2
        xStr = ""
        Do While xFileName <> ""
            Cells(I, 1) = xFileName
            Set RegExp = CreateObject("VBscript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = "/Types*/Page[^s]"
            xFileNum = FreeFile
            Open (xFdItem & xFileName) For Binary As #xFileNum
                xStr = Space(LOF(xFileNum))
                Get #xFileNum, , xStr
            Close #xFileNum
            Cells(I, 2) = RegExp.Execute(xStr).Count
            I = I + 1
            xFileName = Dir
        Loop
        Columns("A:B").AutoFit
    End If
End Sub