VBAでpdftkを用いてPDFプロパティを更新してPDF出力する

VBAを用いつつ、PDFのプロパティ情報を更新するメモです。

AcrobatProであればアクションスクリプト的なものも出来るためあまりニーズはなさそうですが、AcrobatReaderDC環境などであればこのやり方は使えるかもしれません。

コード

まずはコードです。動くことを願っています。

Option Explicit

Const PATH As String = "作業フォルダパス"

'meta情報
Public Type meta
    title As String
    author As String
End Type
Public metainfo As meta '旧meta情報用
Public new_metainfo As meta '新meta情報用

'2回以上
Sub main()

    Dim s_metafile As String
    Dim s_pdf As String
    Dim new_metafile As String
    Dim new_pdf As String
    

    Dim i As Long
    Dim maxRow As Long
    maxRow = Range("A1").SpecialCells(xlLastCell).Row

    'ヘッダー行は省く
    For i = 2 To maxRow
        'pdfファイル有無チェック
        '元pdf
        If existsFile(Cells(i, 1)) Then
            s_pdf = Cells(i, 1)
        Else
            '処理中断
            Exit Sub
        End If
        
        '新pdf
        If Cells(i, 6) <> "" Then
            new_pdf = Cells(i, 6)
        End If
        
        'metaファイルはpdfファイル名に付与
        '1.pdfなら1.txt
        s_metafile = Replace(s_pdf, ".pdf", ".txt")
        '1.pdfならnew1.txt
        new_metafile = Replace(s_pdf, ".pdf", ".txt")
        new_metafile = "new" + new_metafile
        
        'meta情報を出力する
        Call makeMetaInfo(s_pdf, s_metafile)
        
        'meta情報を取得する
        Call getMetaInfo(s_metafile)
        
    'デバグ
'    Cells(i, 2) = metainfo.title
'    Cells(i, 3) = metainfo.author
        
        'meta情報を更新して出力する
        '元meta,新meta
        new_metainfo.title = Cells(i, 4)
        new_metainfo.author = Cells(i, 5)
        Call updateMetaInfo(s_metafile, new_metafile, new_metainfo)
        
        '新しいmeta情報でPDFを出力する
        '元のPDF,更新後meta,新PDF
        Call out_PdfFile(s_pdf, new_metafile, new_pdf)
    Next

    '作成したPDFを移動する
    Call movePDF
    

MsgBox "処理が終了しました"

End Sub

Sub movePDF()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'フォルダを作成する
    Dim folder As String
    folder = Format(now, "yyyymmddhhmmss")
    FSO.CreateFolder PATH & folder
    
    'ファイルを移動する
    Call FSO.MoveFile(PATH & "*_updated.pdf", PATH & folder) ' 複数のファイルをまとめて移動
    
    Set FSO = Nothing
End Sub

'pdfファイルなどのファイルの有無チェック
'対象フォルダはカレントフォルダ
Function existsFile(str As String) As Boolean
    
    Dim FSO As Object
    Dim FilePathName As String
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
        
    FilePathName = ThisWorkbook.PATH & "\" & str
    
    If FSO.FileExists(FilePathName) Then
        existsFile = True
    Else
        existsFile = False
    End If
    
    Set FSO = Nothing
        
End Function

'一回処理
Sub main_one()

    Dim s_metafile As String
    Dim s_pdf As String
    Dim new_metafile As String
    Dim new_pdf As String
    
    
    'pdfファイル有無チェック
    '元pdf
    If existsFile(Cells(2, 1)) Then
        s_pdf = Cells(2, 1)
    Else
        '処理中断
        Exit Sub
    End If
    
    '新pdf
    If Cells(2, 6) <> "" Then
        new_pdf = Cells(2, 6)
    End If
    
    s_metafile = "meta.txt"
    new_metafile = "update_meta.txt"
    
    'meta情報を出力する
    Call makeMetaInfo(s_pdf, s_metafile)
    
    'meta情報を取得する
    Call getMetaInfo(s_metafile)
    
    'meta情報を更新して出力する
    '元metｄa,新meta
    Call updateMetaInfo(s_metafile, new_metafile)
    
    '新しいmeta情報でPDFを出力する
    '元のPDF,更新後meta,新PDF
    Call out_PdfFile(s_pdf, new_metafile, new_pdf)
    
End Sub


'PDFを出力する
Sub out_PdfFile(s_pdf As String, new_metafile As String, new_pdf As String)

    Dim WSH, wExec, sCmd As String
    Dim ret As String
    Dim i As Long
    
    Set WSH = CreateObject("WScript.Shell")

    'カレントディレクトリを移動する
    WSH.CurrentDirectory = PATH

    'コマンド作成
    sCmd = "pdftk " & s_pdf & " " & "update_info_utf8 " & new_metafile & " output " & new_pdf
    
    Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)
    Do While wExec.Status = 0
        DoEvents
    Loop


    Set wExec = Nothing
    Set WSH = Nothing
    
End Sub

'meta情報を更新する
Sub updateMetaInfo(s_metaFileName As String, new_metaFileName As String, new_metainfo As meta)

   'wshであれば戻り値取れる
    Dim WSH, wExec, sCmd As String, Result As String, tmp, i As Long
    Dim metaTitle As String
    Dim metaAuthor As String
    Dim ret As Long

    Result = getMetaFile(s_metaFileName)
'    tmp = Split(Result, vbCrLf)

    Dim strTitle As String
    'strTitle = "タイトル更新"
    strTitle = new_metainfo.title
    Dim strAuthor As String
'    strAuthor = "作成者更新"
    strAuthor = new_metainfo.author


    'タイトルを更新する
    Result = Replace(Result, metainfo.title, strTitle)
    '作成者を更新する
    Result = Replace(Result, metainfo.author, strAuthor)
    
    'メタファイルを出力する
    Call outMetaFile(new_metaFileName, Result)
    

    Set wExec = Nothing
    Set WSH = Nothing
    
End Sub

'meta情報を出力する
Sub outMetaFile(strFileName As String, buf As String)
    
    Dim filepath As String
    filepath = PATH & strFileName
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .WriteText buf
        .SaveToFile filepath, 2 '上書き
        .Close
    End With
    
End Sub

'meta情報の指定fieldを更新する
Function updateMetaValue(field As String, data As Variant, updateValue As String) As String

    Dim i As Long
    
    '指定したinfokeyの次行のkeyを取得する
    
    'title
    If field = "Title" Then
        For i = 0 To UBound(data)
            If InStr(1, data(i), "InfoKey: Title") <> 0 Then
                updateMetaValue = getValue(CStr(data(i + 1)))
                Exit Function
            End If
        Next
    End If
        
    'Author
    If field = "Author" Then
        For i = 0 To UBound(data)
            If InStr(1, data(i), "InfoKey: Author") <> 0 Then
                updateMetaValue = getValue(CStr(data(i + 1)))
                Exit Function
            End If
        Next
    End If
    
    updateMetaValue = ""

End Function

'meta情報を出力する
'対象のPDF,出力メタtxt
Sub makeMetaInfo(pdfFileName As String, txtFileName As String)
    Dim WSH, wExec, sCmd As String
    Dim ret As String
    Dim i As Long
    
    Set WSH = CreateObject("WScript.Shell")

    'カレントディレクトリを移動する
    WSH.CurrentDirectory = PATH

    'コマンド作成
    sCmd = "pdftk " & pdfFileName & " " & "dump_data_utf8 > " & txtFileName
    
    Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)
    Do While wExec.Status = 0
        DoEvents
    Loop


    Set wExec = Nothing
    Set WSH = Nothing
    
End Sub

'meta情報を取得する
Sub getMetaInfo(FileName As String)
    Dim WSH, wExec, sCmd As String, Result As String, tmp, i As Long
    

    Result = getMetaFile(FileName)
    tmp = Split(Result, vbCrLf)
    
    'title取得
'    metaTitle = getMetaValue("Title", tmp)
    metainfo.title = getMetaValue("Title", tmp)
    'Author取得
'    metaAuthor = getMetaValue("Author", tmp)
    metainfo.author = getMetaValue("Author", tmp)

    
    Set wExec = Nothing
    Set WSH = Nothing
    
End Sub

'ADOを介してmeta情報ファイルを読み込む
Function getMetaFile(strFileName As String) As String
    Dim file As String
    Dim buf As String
    file = PATH & strFileName
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile file
        buf = .ReadText
        .Close
        getMetaFile = buf
    End With

End Function

'meta情報の指定fieldを返す
Function getMetaValue(field As String, data As Variant) As String

    Dim i As Long
    '指定したinfokeyの次行のkeyを取得する
    
    'title
    If field = "Title" Then
        For i = 0 To UBound(data)
            If InStr(1, data(i), "InfoKey: Title") <> 0 Then
                getMetaValue = getValue(CStr(data(i + 1)))
                Exit Function
            End If
        Next
    End If
        
    'Author
    If field = "Author" Then
        For i = 0 To UBound(data)
            If InStr(1, data(i), "InfoKey: Author") <> 0 Then
                getMetaValue = getValue(CStr(data(i + 1)))
                Exit Function
            End If
        Next
    End If
    
    getMetaValue = ""

End Function

'値のみ取り出す
Function getValue(str As String) As String

    '：以降を取り出して整形
    Dim start As Long
    
    start = InStr(1, str, ":")
    If start <> 0 Then
        getValue = Mid$(str, start + 1, Len(str))
        getValue = Trim$(getValue)
        Exit Function
    End If
    
    getValue = ""

End Function

無駄なコードもありそうですが、ひとまず上で動くと。細かいメモは後述します。

ADOを使っているので、Microsoft ActiveX Data Objects 6.1 Libraryとかバージョンは環境によりけりですが、参照設定が必要ですです。

ここではタイトルや作成者の2つしかいじってませんが、他は必要に応じて追加すればいけるかと。メタ情報が構造化されてないので強引に取っていますがご愛嬌ということで。他に良いアイデアがあるかもしれません。

どう動かすか

基本的に、PATH定数の作業フォルダを便宜的に固定していますが、そこにあるPDFを読み込んで、プロパティ情報等のメタ情報テキストを作成。そのテキストを修正したメタ情報で、PDFをpdftkで作成して、書き換えるということになります。

よって、既存PDF上書きではないのですがそこは運用でカバーしてもらうとして、新規でPDFを修正したプロパティ情報で作るということになります。

シート側では、以下のようなイメージでシートを作っておきます。実際には作業フォルダ下のPDFファイルまでチェックしてないので、セルにあるファイル名がある前提です。その処理が欲しい人は作ってみてください。

D列とE列がポイントです。ここにあるタイトルや作成者でメタ情報を置き換えて、新規PDFを作るということですね。

動かすと、現在日時でフォルダを作ってそこに更新後ファイルPDFが出来ます。

動作結果

例えば1.pdfというプロパティ情報を変えたいPDFがあるとします。

当然ですが、AcrobatReaderDC等では変更出来ません。

このファイルを本プログラムを動かすことで、メタ情報を抜き出して、修正し、その修正した情報でPDFを作るという動きです。

こちらが実行後のPDFです。PDFを新規に作っているので知ってしまえばなんだと思うのですが、一方で既存PDFも保持されていますし、必要であればバックアップとなります。運用的にも良いのかなあという感じがします。上のタイトル、作成者はExcelシート側で変えられるのでエンドユーザー的にも嬉しいですよね。

簡単な解説

あーだこーだやっていますが、そもそも前提として以下でやっています。

  • Windows10
  • KingsoftExcel(VBA)※VBAは同様と思われる
  • pdftk（Free版）をインストール　

PDFメタの読み込みやPDF作成はpdftk頼みなのでそこが崩れると終わりですね。これらはVBAからはWSHなどでコマンドを叩ける感じです。

main_one関数は一回だけ回す処理ですのでテストコードです。まずこれを動かして動くかどうかですね。main関数がメインです。シートにあるPDFファイルだけ回すイメージです。

はまったポイント

バッチ処理にこだわりすぎていたのですが、コマンドラインでの結果を返すところでまず躓いています。Windows環境コマンドプロンプトの結果はshift-jisっぽいのか、UTF-8でメタ情報をテキストファイルで作ると文字化けしており、この出力時の文字受け取りに苦労しました。

結果的には、ADOのStreamを使ってシンプルにファイルを読み込む、出力するということで回避しました。VBAで文字コードを意識するとADOとかになっちゃいそうですね。

以下参考までに。

Gyazo

上がメタ情報をpdftkで出力したものです。dump_data_utf8で出しています。これいい感じなんですが、VBA側で読み取ると、

 title-->繧ｿ繧､繝医Ν・・
 author-->菴懈・閠・ｼ・
'Result = wExec.StdOut.ReadAllの結果

みたいになります（笑）結局コマンドプロンプトの出力結果を受け取るという作りは無理と諦めたということですね。ここが一番はまりましたね。同じところでハマる人も多そうです。回避策はADOのStreamくらいしか思いつかなくそれを使いました。

あと、ファイル入出力を通さずという感じもありそうですが、一旦ADOをかまさないと駄目なので、このあたりが速度は遅いのかもしれないですね。未検証ですが。

参考になったサイト

Windowsバッチでファイル内の特定文字を置換する方法

テキストファイルの内容を区切り文字でトークンに分解し繰り返し処理を使う(FOR)

バッチファイルでやろうとしていた時に。置換できるんですが、そもそもバッチファイルでやる縛りがあるわけではないので。

【VBA】エクセルでbatファイル実行

VBAでバッチファイルなどコマンドを叩くイメージの参考になりました。

MS-DOSコマンドの標準出力を取得する

コマンド叩いた結果を取る時に。WSHでやれるというのは学びになりました。今回は結果はほぼ使ってないのですが。

作業ディレクトリを指定してプログラムを実行

作業フォルダ等を指定しないとバッチも動いてくれない時に。

課題

数件しか試してないのですが、大量にPDFがあるとファイル出力をVBAでやっているので遅そうという印象です。やってないので、不明です。

あとはPDFファイルの自動取得ですがこれは難しくないのでそこを入れるとぐっと使いやすくなりそうですね。

もし同様のカスタマイズ等ご希望であればお問い合わせください。

タイトルとURLをコピーしました