EXCEL VBA AcrobatReaderやAdobeを使わずにPDFのページ数を取得する方法

dタイトルの通り、

EXCEL VBA AcrobatやAdobeを使わずにPDFのページ数を取得したい

と思ったときにめちゃくちゃ調べまわったのでその結果をまとめる。

結論から言うと、イメージしていたやり方では

PDFのある特定のバージョンで特定の構造の場合は取得できるが、

取得できない場合があった。

以下調査結果まとめ

<調査結果まとめ>

◆VBAでPDFのPages【ﾍﾟｰｼﾞｽﾞ】コレクションのCount【ｶｳﾝﾄ】プロパティにはアクセスできない（AdobeでWindowsのプロパティはサポートしていないため）

◆PDFをバイナリ形式で開き、正規表現でページタグになる部分をカウントしたり、値を取得する。

　イメージはこれが一番近いが、取得できないPDFがある。PDFをテキストエディタで開くとわかるが、正規表現に該当しないパターンのファイルはページ数が取得できない。

 　VBA Page Count | MrExcel Message Boardより

　https://www.mrexcel.com/board/threads/vba-page-count.347911/page-2

しかし、実行してみると14行目のページ総数が64となっているが実際は1ページのPDFファイルのため、実行結果にミスがあることがわかる。

そのため、確実に正しい結果が取得できる正規表現にしぼる必要があった。

実行画面

◆フリーソフトでページ数を表示できるものがある

　ComPDFというツールで取得できるらしい。（試していない）

　ツールダウンロード：http://www.ne.jp/asahi/foresth/home/にアクセスしComPDFをダウンロード

　紹介していたページ：「バヤシのブログ」さん

　【時短テクニック】複数のPDFのページ数を開かずにカウントする方法

　https://salaryman-knowhow.com/pdf-page-count/

◆VBAでPDFファイルを開き、文書のプロパティを開き、ページ数を取得する

　これが現段階では最強ではなかろうか。

　64bit版は先頭のライブラリの定義を差し替えるといけると思います。

　とりあえず実行できるところまで試した。(DCをインストールしたくない)

　そのまま実行したらエラーが発生した。

　参照設定「UIAutomationClient」の設定が必要。

　なんとコメントに書いてあったが見逃していたｗ

　「初心者備忘録」さん

　Acrobat Reader DCを利用してPDFファイルのページ数を取得するVBAマクロ

　https://www.ka-net.org/blog/?p=11981

◆上記を踏まえ、おまけで私が実装した妥協PDF、エクセル、ワードのページ数取得マクロ

・一部PDFのページ数が取得できません。

・シート名”一覧”としているため、strListの定義を変えれば任意のシート名に変更できます。

・検索対象のフォルダはB2セルに入力するようにしているのでダイアログ表示にするなど変更してください。

・取得できないパターンはエラー文言をセルに出力するようにしています。

実行画面

以下ソース

Option Explicit

'※64ビット版Officeで実行する場合は要コード変更
'UIAutomationClient(UIAutomationCore.dll)要参照

#If Win64 Then

Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lparam As LongPtr) As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

#Else

Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long

Private Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)

#End If
Private Const WM_COMMAND As Long = &H111


Dim rowCntOutput As Long
Dim cntListNum As Long

Const strList As String = "一覧"
Const rowTitle As Long = 5
Const colNo As Long = 2
Const colPath As Long = 3
Const colFile As Long = 4
Const colPage As Long = 5
Const rowList As Long = 200 'リスト最大200行

'リストクリア関数
Sub delFileList()
    Dim wsh As Worksheet
    Set wsh = ThisWorkbook.Worksheets(strList)
    
    'タイトル行の次からリスト最大行までのRangeをクリア
    wsh.Range( _
        wsh.Cells(rowTitle + 1, colNo), _
        wsh.Cells(rowList, colPage)).Clear
        
    'ワークシートオブジェクトは後処理不要という記述もあるが、明示的にクリアする。
    Set wsh = Nothing
End Sub

'ファイルリスト取得メイン処理
Sub FileList()
    Dim listwsh As Worksheet
    Dim strPath As String
    
    Set listwsh = ThisWorkbook.Worksheets(strList)
    
    strPath = listwsh.Cells(2, 2).Value
    listwsh.Cells(rowTitle, colNo).Value = "No"
    listwsh.Cells(rowTitle, colPath).Value = "パス"
    listwsh.Cells(rowTitle, colFile).Value = "ファイル名"
    listwsh.Cells(rowTitle, colPage).Value = "ページ総数"
    
    Call delFileList
    
    '出力行初期化、タイトル行の次から出力
    rowCntOutput = rowTitle + 1
    'ファイルリストNo.を初期化
    cntListNum = 1
    
    Call getFileList(strPath)
    listwsh.Select
    Set listwsh = Nothing
End Sub

'ファイルリスト取得処理
Sub getFileList(searchpath As String)

    Dim listwsh As Worksheet
    Dim fso As Object
    Dim objFiles As Object
    Dim objFolders As Object
    Dim separateNum As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set listwsh = ThisWorkbook.Worksheets(strList)

    For Each objFolders In fso.GetFolder(searchpath).subfolders
        Call getFileList(objFolders.Path)
    Next
    
    For Each objFiles In fso.GetFolder(searchpath).Files
        separateNum = InStrRev(objFiles.Path, "\")
       
        If (objFiles.Attributes And 4) > 0 Or _
           (objFiles.Attributes And 2) > 0 Then
            'Systemファイルおよび隠しファイルは処理しない
        Else
            listwsh.Cells(rowCntOutput, colNo).Value = cntListNum
            listwsh.Cells(rowCntOutput, colPath).Value = Left(objFiles.Path, separateNum - 1)
            listwsh.Cells(rowCntOutput, colFile).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
            
            Call getFilePage(objFiles.ShortPath)
            rowCntOutput = rowCntOutput + 1
            cntListNum = cntListNum + 1
        End If
    Next
       

    'リスト範囲に枠線
    listwsh.Range( _
        listwsh.Cells(rowTitle, colNo), _
        listwsh.Cells(rowCntOutput - 1, colPage)).Borders.LineStyle = True
    'リストのタイトル行に色付け
    listwsh.Range( _
        listwsh.Cells(rowTitle, colNo), _
        listwsh.Cells(rowTitle, colPage)).Interior.ColorIndex = 35
    
    '後処理
    Set objFiles = Nothing
    Set objFolders = Nothing
    Set fso = Nothing
    Set listwsh = Nothing

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Sub getFilePage(strFile As String)
    Dim DotPos As Long
    Dim PageNum As Variant
    Dim strType As String
    
    Dim yenPos As Long
    Dim strfname As String
    
    yenPos = InStrRev(strFile, "\")
    If yenPos > 0 Then
        strfname = LCase(Mid(strFile, yenPos + 1))
    End If
    
    PageNum = 0
    DotPos = InStrRev(strFile, ".")
    
    If DotPos > 0 Then
        strType = LCase(Mid(strFile, DotPos + 1))
        If strType = "xlsx" Or _
           strType = "xls" Or _
           strType = "xlsm" Then
            PageNum = getExcelPageNum(strFile)
        ElseIf strType = "docx" Or strType = "doc" Then
            PageNum = getWordPageNum(strFile)
        ElseIf strType = "pdf" Then
            
            'ここを切り替えると他の方のコードと差し替えることが可能
            'PageNum = getPdfPageNum(strFile)
            PageNum = GetPageNum(strFile)
            '「UIAutomationClient」の参照設定が必要
            'PageNum = getPdfPageNumProperty(strFile)
        Else
            'Excel、Word、PDFファイル以外
            PageNum = 0
        End If
        ThisWorkbook.Worksheets(strList).Cells(rowCntOutput, colPage).Value = PageNum
    End If
    
End Sub

Private Function getExcelPageNum(strFile As String) As Variant

    Dim wbk As Workbook
    Dim workwsh As Worksheet
    Dim retVal As Variant
    Dim 表示シート数 As Long
    
    'ファイル有無をチェック
    Dim chkstr As String
    chkstr = Dir(strFile)
    If chkstr = "" Then
        'ファイルなし
        getExcelPageNum = "ファイルなし"
        Exit Function
    End If
    
    'ファイルを開いているかチェック
    Dim chkwsh As worksbook
    For Each chkwsh In Workbooks
        If chkwsh.Name = chkstr Then
            '同名のファイルを開いている
            Exit For
        Else
            Set chkwsh = Nothing
        End If
    Next
    
    If chkwsh Is Nothing Then
        'ファイルを読み取り専用、通知なし、リンク更新なし　で開く
        Set wbk = Workbooks.Open(Filename:=strFile, notify:=False, UpdateLinks:=0, ReadOnly:=True)
    Else
        '既に開いているファイルを指定
        Set wbk = chkwsh
    End If
    Set chkwsh = Nothing

    '非表示シートを含めたシート数
    'retVal = wbk.Worksheets.Count

    '表示シートのみのシート数
    表示シート数 = 0
    For Each workwsh In wbk.Worksheets
        If workwsh.Visible Then
            表示シート数 = 表示シート数 + 1
        Else
            '非表示シートをカウントしない
        End If
    Next
    retVal = 表示シート数

    getExcelPageNum = retVal
    
    '開いたファイルを保存せずにクローズ
    '指定フォルダ以下で開いていたファイルも閉じるので注意
    wbk.Close SaveChanges:=False

    Set workwsh = Nothing
    Set wbk = Nothing


End Function

Private Function getWordPageNum(strFile As String) As Variant

    Dim objWord As Object
    Dim objDoc As Object
    Dim retVal As Long
    
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Open(Filename:=strFile, ReadOnly:=True)
    
    retVal = objDoc.Content.Information(4)
    objDoc.Close SaveChanges:=False
    objWord.Quit
    
    Set objDoc = Nothing
    Set objWord = Nothing
    
    getWordPageNum = retVal
    
End Function

Private Function getPdfPageNum(strFile As String) As Variant

    Dim objPdf As Object
    Dim objwork As Object
    Dim objResult As Object
    
    Dim xFileNum As Long
    Dim xStr As String
    Dim retVal As Long

    retVal = 0
    'Openはパスに環境依存文字が含まれるとエラー
    'FSOでバイナリ開けない
    'Fso.ShortPathだと環境依存文字が含まれないかも
    'vbFormUnicode=128,vbUnicode=64 参照設定しないので直値指定
    'VBEはUnicode変換するとShift-JIS以外は"?"となるので環境依存文字判定
    Dim temp As String
    temp = StrConv(StrConv(strFile, 128, 1041), 64, 1041)
    
    If InStr(temp, "?") <= 0 Then
        xFileNum = FreeFile
        Open (strFile) For Binary Access Read As #xFileNum
        xStr = Space(LOF(xFileNum))
        Get #xFileNum, , xStr
        Close #xFileNum
        
        Set objPdf = CreateObject("VBscript.RegExp")
        objPdf.Global = True
        
        objPdf.Pattern = "<</Count\s(\d+)"
        Set objResult = objPdf.Execute(xStr)
        For Each objwork In objResult
            getPdfPageNum = objResult.Item(0).SubMatches.Item(0)
            Set objPdf = Nothing
            Set objwork = Nothing
            Set objResult = Nothing
            Exit Function
        Next
        
        objPdf.Pattern = "/Type\s*/Page[^s]"
        Set objResult = objPdf.Execute(xStr)
        For Each objwork In objResult
            getPdfPageNum = objResult.Count
            Set objPdf = Nothing
            Set objwork = Nothing
            Set objResult = Nothing
            Exit Function
        Next
    
        Set objPdf = Nothing
        Set objwork = Nothing
        Set objResult = Nothing
    Else
        getPdfPageNum = "パスに環境依存文字が含まれています"
        Exit Function
    End If
    
    getPdfPageNum = "PDFページ取得失敗..."
   
End Function

' trial ver
' Seiji Fujita  rev.2  June 02, 2020 (base code: 'Haluk 19/10/2008)
' Added a file size check to prevent a zero byte file from being created if the file does not exist
' When file does not exit or filesize equal 0, return value = NOTEXIST
' When If it is impossible to count, return value = UNSUPPORTNUM
Function GetPageNum(ByVal PDF_File As String) As Long
    Const NOTEXIST As Long = 0
    Const UNSUPPORTNUM As Long = -99
    Dim FileNum As Long
    Dim strRetVal As String
    Dim RegExp
    Dim nFileLen As Long
    Dim getpage0 As Long, getpage1 As Long, getpage2 As Long, _
        getpage3 As Long, getpage4 As Long, getpage5 As Long, _
        getpage6 As Long, getpage7 As Long

    Application.Volatile

    ' return NOTEXIST when filesize equal zero or file does not exist
    On Error Resume Next
    nFileLen = FileLen(PDF_File)
    On Error GoTo 0
    If nFileLen <= 0 Then
        GetPageNum = NOTEXIST
        Exit Function
    End If

    FileNum = FreeFile
    Open PDF_File For Binary As #FileNum
        strRetVal = Space(LOF(FileNum))
        Get #FileNum, , strRetVal
    Close #FileNum

    Set RegExp = CreateObject("VBscript.RegExp")
    RegExp.Global = True

    ' getpage0 is the basics, but depending on the PDF,
    ' the number of this pattern differs from the number of pages
    RegExp.Pattern = "/Type\s*/Page[^s]"
    getpage0 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/Resources"
    getpage1 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/ProcSet\s*\[/PDF"
    getpage2 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/Type/Catalog/Page\s*"
    getpage3 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/ExtGState"
    getpage4 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/Type/ObjStm"
    getpage5 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "/Subtype/"
    getpage6 = RegExp.Execute(strRetVal).Count

    RegExp.Pattern = "<rdf:" ' "JFIF"  ' "DeviceRGB"     ' "/Ordering\(Identity"   ' "Registry\(Adobe\)"     ' "/BM/Normal"
    getpage7 = RegExp.Execute(strRetVal).Count

    If getpage0 > 0 Then
        GetPageNum = getpage0
    Else
        If getpage5 > 0 Then
            If getpage7 <= 0 Then
                GetPageNum = getpage6 - getpage5 - getpage4 - 1
            Else
                GetPageNum = UNSUPPORTNUM   ' cannot get right number; getpage6 - getpage7 - 2 * getpage1 ' not logical, adhoc
            End If
        Else
            GetPageNum = MathMax(MathMax(getpage1, getpage2), getpage3)
            ' you can use below with MS Excel, insted above
            ' GetPageNum = Application.WorksheetFunction.Max(getpage1, getpage2, getpage3)
            If GetPageNum > getpage4 Then
                GetPageNum = GetPageNum - getpage4
            End If
        End If
    End If
End Function

Function MathMax(ByVal a As Long, ByVal b As Long) As Long
    If a >= b Then
        MathMax = a
    Else
        MathMax = b
    End If
End Function
 
Private Function getPdfPageNumProperty(PDFPath As String) As Variant
  Dim num As Long
   
  num = GetPDFNumPagesUsingAdobeReader(PDFPath)
  getPdfPageNumProperty = num
End Function
 
Private Function GetPDFNumPagesUsingAdobeReader(ByVal PDFPath As String) As Long
'Adobe Readerの[文書のプロパティ]ダイアログからPDFのページ数を取得
  Dim uiAuto As CUIAutomation
  Dim elmApp As IUIAutomationElement
  Dim elmRoot As IUIAutomationElement
  Dim elmDialog As IUIAutomationElement
  Dim elmTabItem As IUIAutomationElement
  Dim elmTextPageNumCaption As IUIAutomationElement
  Dim elmTextPageNum As IUIAutomationElement
  Dim elmButtonCancel As IUIAutomationElement
  Dim elmButtonClose As IUIAutomationElement
  Dim ptnSel As IUIAutomationSelectionItemPattern
  Dim ptnInvoke As IUIAutomationInvokePattern
  Dim hApp As Long
  Dim readerPath As String
  Dim ret As Long
   
  'Adobe Readerで指定したPDFファイルを表示
  readerPath = GetAdobeReaderPath
  If Len(Trim(GetAdobeReaderPath)) < 1 Then GoTo Fin
  Shell """" & readerPath & """" & " " & """" & PDFPath & """", vbNormalFocus
   
  'Adobe Reader取得
  '※PDF表示まで多少時間が掛かる場合有り
  Set uiAuto = New CUIAutomation
  Set elmRoot = uiAuto.GetRootElement
  Do
    Set elmApp = GetElement(uiAuto, _
                            elmRoot, _
                            UIA_ClassNamePropertyId, _
                            "AcrobatSDIWindow", _
                            UIA_WindowControlTypeId)
    Sleep 200
    DoEvents
  Loop While elmApp Is Nothing
   
  '[文書のプロパティ]ダイアログ取得
  hApp = elmApp.GetCurrentPropertyValue(UIA_NativeWindowHandlePropertyId)
  PostMessage hApp, WM_COMMAND, &H1794, 0 '文書のプロパティ表示
  Do
    Set elmDialog = GetElement(uiAuto, _
                               elmApp, _
                               UIA_NamePropertyId, _
                               "文書のプロパティ", _
                               UIA_WindowControlTypeId)
    Sleep 200
    DoEvents
  Loop While elmDialog Is Nothing
   
  '[概要]タブ選択
  Set elmTabItem = GetElement(uiAuto, _
                              elmDialog, _
                              UIA_NamePropertyId, _
                              "概要", _
                              UIA_TabItemControlTypeId)
  If elmTabItem Is Nothing Then GoTo Fin
  Set ptnSel = elmTabItem.GetCurrentPattern(UIA_SelectionItemPatternId)
  ptnSel.Select
   
  '[ページ数]取得
  Set elmTextPageNumCaption = GetElement(uiAuto, _
                                         elmDialog, _
                                         UIA_NamePropertyId, _
                                         "ページ数 :", _
                                         UIA_TextControlTypeId)
  If elmTextPageNumCaption Is Nothing Then GoTo Fin
  Set elmTextPageNum = uiAuto.RawViewWalker.GetNextSiblingElement(elmTextPageNumCaption)
  If elmTextPageNum Is Nothing Then GoTo Fin
  ret = CLng(elmTextPageNum.CurrentName)
   
  'ダイアログを閉じてアプリケーション終了
  Set elmButtonCancel = GetElement(uiAuto, _
                                   elmDialog, _
                                   UIA_NamePropertyId, _
                                   "キャンセル", _
                                   UIA_ButtonControlTypeId)
  If elmButtonCancel Is Nothing Then GoTo Fin
  Set ptnInvoke = elmButtonCancel.GetCurrentPattern(UIA_InvokePatternId)
  ptnInvoke.Invoke
  Set elmButtonClose = GetElement(uiAuto, _
                                  elmApp, _
                                  UIA_NamePropertyId, _
                                  "閉じる", _
                                  UIA_ButtonControlTypeId)
  If elmButtonClose Is Nothing Then GoTo Fin
  Set ptnInvoke = elmButtonClose.GetCurrentPattern(UIA_InvokePatternId)
  ptnInvoke.Invoke
   
Fin:
  GetPDFNumPagesUsingAdobeReader = ret
End Function
 
Private Function GetAdobeReaderPath()
'Adobe Reader(AcroRd32.exe)のパスを取得
  Dim folderPath As String
  Dim filePath As String
  Dim itm As Object
  Const ExeName As String = "AcroRd32.exe"
    
  '[プログラムと機能]からAdobe Readerのインストール先フォルダを取得
  With CreateObject("Shell.Application").Namespace("shell:::{7b81be6a-ce2b-4676-a29e-eb907a5126c5}")
    For Each itm In .Items
      If InStr(LCase(itm.Name), "adobe") And InStr(LCase(itm.Name), "reader") Then
        '[Extended Asian Language font pack]は除外
        If InStr(LCase(itm.Name), "extended") < 1 Then
          folderPath = .GetDetailsOf(itm, 10)
          Exit For
        End If
      End If
    Next
  End With
   
  'Adobe Readerのパスを取得
  With CreateObject("Scripting.FileSystemObject")
    filePath = .BuildPath(folderPath, "Reader")
    filePath = .BuildPath(filePath, ExeName)
    If .FileExists(filePath) = True Then GetAdobeReaderPath = filePath
  End With
End Function
 
Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0) As IUIAutomationElement
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition
       
  Set cndFirst = uiAuto.CreatePropertyCondition( _
                   propertyId, _
                   propertyValue _
                 )
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition( _
                      UIA_ControlTypePropertyId, _
                      ctrlType _
                    )
    Set cndFirst = uiAuto.CreateAndCondition( _
                     cndFirst, _
                     cndSecond _
                   )
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function