VBAにてpdfのしおりを取得したい

前提・実現したいこと

pdfのしおり（ブックマーク）をセルに反映させたい。その際、しおりの階層とページ数も取得したい。

発生している問題・エラーメッセージ

VBEのイミディエイトウィンドウにページ数やしおりを出力する方法は分かったが、セルに反映させる方法が分からない

ソースコード

Public Sub Sample()
    Dim Acroapp As Object 'AcroApp
    Dim AcroAV As Object 'AcroAVDoc
    Dim pg As Object 'AcroAVPageView
    Dim js As Object
    Dim bm As Object
  
    Dim dlg As FileDialog
    Dim path As Variant
  
    'ファイルパスの取得
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
    If dlg.Show = False Then Exit Sub
    path = dlg.SelectedItems(1)
    Cells(3, 2) = path
    
    'オブジェクトの作成（インスタンス化）
    Set Acroapp = CreateObject("AcroExch.App")
    Set AcroAV = CreateObject("AcroExch.AVDoc")
  
    If AcroAV.Open(path, "") = True Then
        'アプリ起動
        Acroapp.Show
    
        Set pg = AcroAV.GetAVPageView
        Set js = AcroAV.GetPDDoc.GetJSObject
        Set bm = js.bookmarkroot
        DumpBookmark bm, pg
        AcroAV.Close 1
        Acroapp.Hide
        Acroapp.Exit
    End If
    
    Set Acroapp = Nothing
    Set AcroPD = Nothing
    Set AcroAV = Nothing
End Sub
 
Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object)
    'しおりの情報を出力
    Dim cld As Variant, cld2 As Variant
    
    On Error Resume Next
        cld = bm.Children
    On Error GoTo 0
        If IsEmpty(cld) = False Then
            For Each cld2 In cld
                'しおり選択
                cld2.Execute
                Debug.Print "名前：" & cld2.Name & vbTab & "ページ：" & pg.GetPageNum + 1
                DumpBookmark cld2, pg
            Next
        End If
End Sub

![しおり](09dc6de90bbe0e5f9963c6429f24b633.png)
![現状](3a2156ed6f07c8885de9348d6efc5534.png)
![目標](424c1969e6b956dbf4ef794139dfa5d1.png)
![結果](e5c90f7a4fdb02436a7731ca74226b04.png)

行動規範の内容に同意します

回答1件

ベストアンサー

こんな感じでどうでしょうか。

VBA
1Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object, Optional col As Long = 0)
2    'しおりの情報を出力
3    Dim cld As Variant, cld2 As Variant
4    On Error Resume Next
5    cld = bm.Children
6    On Error GoTo 0
7    
8    Dim ws As Worksheet, newRow As Long
9    Set ws = ActiveSheet
10    newRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
11    col = col + 1
12    
13    If IsEmpty(cld) = False Then
14    For Each cld2 In cld
15        'しおり選択
16        cld2.Execute
17        Debug.Print "名前：" & cld2.Name & vbTab & "ページ：" & pg.GetPageNum + 1
18        ws.Cells(newRow, col).Value = "名前：" & cld2.Name & vbTab & "ページ：" & pg.GetPageNum + 1
19        DumpBookmark cld2, pg, col
20    Next
21    End If
22End Sub

投稿2021/03/14 08:15

jinoji

総合スコア4592

tista504

2021/03/15 23:31

回答ありがとうございます。そして返信が遅れてしまいすみません。もう一つお聞きしたいのですが、最終的にはページ数とタイトルを分けて取得したいと考えています。また、タイトルは階層毎に分ける予定です。そこで、ご指摘いただいた資料を基に再度、コードを組みなおしたのですが、うまくいかず困っています。再度、ご指導願えないでしょうか。よろしくお願いします。以下、コードです。 Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object, Optional i As Long) 'しおりの情報を出力 Dim cld As Variant, cld2 As Variant On Error Resume Next cld = bm.Children On Error GoTo 0 Dim ws As Worksheet, j As Long Set ws = ActiveSheet i = ws.Range("B" & Rows.Count).End(xlUp).row + 1 j = 2 If IsEmpty(cld) = False Then For Each cld2 In cld 'しおり選択 cld2.Execute ws.Cells(i, 2).Value = pg.GetPageNum + 1 j = j + 1 ws.Cells(i, j).Value = cld2.Name DumpBookmark cld2, pg, i Next Else j = j + 1 End If End Sub

jinoji

2021/03/16 00:18

「最終的にはページ数とタイトルを分けて取得したいと考えています。また、タイトルは階層毎に分ける予定です。」の結果がうまくイメージできません。「期待する結果の画像」「いまのコードの結果の画像」を作って追記してもらったら、何らかのアドバイスができるかもしれません。

tista504

2021/03/16 01:01

言葉足らずで大変申し訳ございません。また、写真の貼り付け方法が分からなかったため、ギガファイル便を使用しました。以下のULRよりダウンロードお願いします。 https://38.gigafile.nu/0323-4865cbe2bf4e5c800a844cb5a4adfe9c

jinoji

2021/03/16 01:39

質問の編集画面に「画像の挿入」アイコンがあると思います。

tista504

2021/03/16 02:37

ありがとうございます。スクショを追加しました。一番上がしおり、真ん中が現状、一番下がやりたいこととなっております。

jinoji

2021/03/16 03:02

こうするとどうなりますか？ Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object, Optional col As Long) 'しおりの情報を出力 Dim cld As Variant, cld2 As Variant On Error Resume Next cld = bm.Children On Error GoTo 0 Dim ws As Worksheet, i As Long Set ws = ActiveSheet i = ws.Range("B" & Rows.Count).End(xlUp).Row + 1 col = col + 1 If IsEmpty(cld) = False Then For Each cld2 In cld 'しおり選択 cld2.Execute ws.Cells(i, 2).Value = pg.GetPageNum + 1 ws.Cells(i, 2 + col).Value = cld2.Name DumpBookmark cld2, pg, col Next End If End Sub

tista504

2021/03/16 04:14

返信ありがとうございますご回答いただいたコードを用いて回したのですが、うまくいきませんでした。結果の図面を追加で載せてますので、ご確認よろしくお願いします。

jinoji

2021/03/16 07:22

Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object, Optional col As Long) 'しおりの情報を出力 Dim cld As Variant, cld2 As Variant On Error Resume Next cld = bm.Children On Error GoTo 0 Dim ws As Worksheet, i As Long Set ws = ActiveSheet col = col + 1 If IsEmpty(cld) = False Then For Each cld2 In cld 'しおり選択 cld2.Execute i = ws.Range("B" & Rows.Count).End(xlUp).Row + 1 ws.Cells(i, 2).Value = pg.GetPageNum + 1 ws.Cells(i, 2 + col).Value = cld2.Name DumpBookmark cld2, pg, col Next End If End Sub

jinoji

2021/03/16 07:22

あるいは Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object) 'しおりの情報を出力 Dim cld As Variant, cld2 As Variant On Error Resume Next cld = bm.Children On Error GoTo 0 Dim ws As Worksheet, i As Long Set ws = ActiveSheet If IsEmpty(cld) = False Then For Each cld2 In cld 'しおり選択 cld2.Execute i = ws.Range("B" & Rows.Count).End(xlUp).Row + 1 ws.Cells(i, 2).Value = pg.GetPageNum + 1 ws.Cells(i, 3 + UBound(Split(cld2.Name, "."))).Value = cld2.Name DumpBookmark cld2, pg Next End If End Sub

tista504

2021/03/16 11:05

回答ありがとうございます。確かに上のコードだと数字で管理されている場合は取得することができるのですが、文字が入力されている場合は文字のしおりが1階層に入ってしまいます。なにか、しおりの階層を取得する方法は知らないでしょうか？度々質問してしまい、申し訳ございません。

jinoji

2021/03/16 11:30 編集

Private Sub DumpBookmark(ByVal bm As Object, ByVal pg As Object, Optional col As Long) 'しおりの情報を出力 Dim cld As Variant, cld2 As Variant Dim ws As Worksheet, i As Long Set ws = ActiveSheet col = col + 1 bm.Execute i = ws.Range("B" & Rows.Count).End(xlUp).Row + 1 ws.Cells(i, 2).Value = pg.GetPageNum + 1 ws.Cells(i, 2 + col).Value = cld2.Name On Error Resume Next cld = bm.Children On Error GoTo 0 If IsEmpty(cld) = False Then For Each cld2 In cld DumpBookmark cld2, pg, col Next End If End Sub

行動規範の内容に同意します