しおり用pdfmarkを挿入するWORDマクロ

それなりに動くものができましたので、投稿します。
WORDのアウトライン番号のついたパラグラフを拾って、PDFのしおり(Bookmark)
用の pdfmark を、PRINTフィールド(PostScriptコード挿入用のフィールド)に
埋め込みます。

使い方
0. 添付のリストを拡張子 .bas で保存する。
1. WORD文書のコピーを作る
  このマクロは、PRINTフィールドを埋め込んで放ったらかしにしますので、
  もとの文書のコピーを作っておきます。
2. コピーをWORDで開く
3. マクロを実行する
  ツール→マクロ→Visual Basic Editor で Visual Basic Editorを開く
  ファイル→ファイルのインポート で 0.で保存した .bas を開く
  WORD本体のウィンドウの方にフォーカスを移して、Alt+F8 を押す。
  BookmarkPdfmark を選択して実行
4. 実行が終わったら、PostScript経由でPDFを印刷する。
  しおり(Bookmark)が添付された PDF ができあがります。
  全てのWORD文書がうまくいくとは限らないですが(理由は分からない ;-<)。


私の環境
・Windows 2000 Professional
・Office XP Personal (WORD 2002)
・プリンタドライバ: 参考文献[1]の中で参照されているドライバ：
  http://www.pdfhacks.com/virtual_printer/pdf_hacks_vpk-1.1.zip
・ghostscript 7.05
・RedMon 1.7

参考文献
[1] Sid Steward, "PDF HACKS" (O'Reilly; ISBN 0-596-00655-1)
    サンプル: http://www.oreilly.com/catalog/pdfhks/chapter/index.html
[2] Andrew Savikas, "WORD HACKS" (O'Reilly; ISBN 0-596-00493-1)
    サンプル: http://www.oreilly.com/catalog/wordhks/chapter/index.html
[3] pdfmark Reference Manual (Technical Note #5150)
    Adobeのサイトのどこか。URLは忘れた ;-<
[4] pdfmark primer
    http://www.pdflib.com/pdffiles/pdfmark_primer.pdf

なお、商用、非商用問わず、このソースのいかなる複写、改変、修正も許諾します。
このプログラムについては何の保証もしません。

----------------------------------------------------------------------
Attribute VB_Name = "BookmarkPdfmark"
Private Const debugPrint As Boolean = False
Private Const maxEnumLevel As Integer = 9
Private Const maxOpenLevel As Integer = 1

Private Type markInfo
    title As String
    name As String
    level As Integer
    childNum As Integer
    page As Integer
    top As Double
End Type

Dim outlines() As markInfo
Dim outlineLastIndex As Integer
Dim outlineLevel(9) As Integer

Private Function makeName(level As Integer, idx As Integer) As String
    makeName = "para__" & Right("0000" & CStr(idx), 4) & "__"
End Function

Private Sub init(doc As Document)
    Dim i As Integer
    ReDim outlines(doc.Paragraphs.Count)
    With outlines(0)
        .title = "(The top of the document)"
        .name = makeName(0, 0)
        .level = 0
        .childNum = 0
        .page = 0
        .top = 0
    End With
    outlineLastIndex = 1
    outlineLevel(0) = 0
    For i = 1 To 9
        outlineLevel(i) = -1
    Next
End Sub

Private Function makeTitle(str As String) As String
    Dim i As Long, tail As Long
    Dim code As Integer
    Dim touch As Boolean
    Dim s As String, ret As String, p As String
    touch = False
    ret = "<FEFF"
    p = Trim(Left(str, Len(str) - 1))
    If Len(p) > 126 Then
        p = Left(p, 123) & "..."
    End If
    tail = Len(p)
    For i = 1 To tail
        s = Mid(p, i, 1)
        code = AscW(s)
        If code < 0 Or code > 127 Then
            touch = True
        End If
        ret = ret & Right("0000" & Hex(code), 4)
    Next
    ret = ret & ">"
    If touch = True Then
        makeTitle = ret
    Else
        makeTitle = "(" & p & ")"
    End If
End Function

Private Sub putField(para As Paragraph, idx As Integer)
    Dim rng As Range
    Dim str As String
    Set rng = para.Range
    str = "\p para " & Chr(34) & _
            Chr(13) & "% " & outlines(idx).name & Chr(13) & _
            Chr(34)
    rng.End = rng.start
    para.Range.Fields.Add Range:=rng, Type:=wdFieldPrint, text:=str
End Sub

Private Sub putParagraph(para As Paragraph)
    Dim idx As Integer
    Select Case para.outlineLevel
    Case wdOutlineLevel1: idx = 1
    Case wdOutlineLevel2: idx = 2
    Case wdOutlineLevel3: idx = 3
    Case wdOutlineLevel4: idx = 4
    Case wdOutlineLevel5: idx = 5
    Case wdOutlineLevel6: idx = 6
    Case wdOutlineLevel7: idx = 7
    Case wdOutlineLevel8: idx = 8
    Case wdOutlineLevel9: idx = 9
    Case Else: idx = -1
    End Select
    If idx > maxEnumLevel Then
        idx = -1
    End If
    If idx > 0 Then
        Dim i As Integer, parent As Integer
        parent = outlineLevel(idx - 1)
        If idx > 0 And parent >= 0 Then
            Dim text As String
            Dim page As Integer
            Dim top As Double
            outlineLevel(idx) = outlineLastIndex
            For i = idx + 1 To 9
                outlineLevel(i) = -1
            Next
            With para.Range
                text = .ListFormat.ListString & " " & .text
                .End = .start
                .Select
            End With
            With Selection
                page = .Information(wdActiveEndPageNumber)
                top = .PageSetup.pageHeight - _
                    .Information(wdVerticalPositionRelativeToPage)
            End With
            With outlines(outlineLastIndex)
                .title = makeTitle(text)
                .name = makeName(idx, outlineLastIndex)
                .level = idx
                .childNum = 0
                .page = page
                .top = top
            End With
            outlines(parent).childNum = outlines(parent).childNum + 1
            If debugPrint = True Then
                putField para:=para, idx:=outlineLastIndex
            End If
            outlineLastIndex = outlineLastIndex + 1
        End If
    End If
End Sub

Private Sub outBookmark(doc As Document)
    Dim i As Integer, childNum As Integer
    Dim rng As Range
    Dim str As String
    str = "\p page " & Chr(34) & Chr(13) & _
        "/pdfmark where " & _
        "{pop} {userdict /pdfmark /cleartomark load put} ifelse" & _
        Chr(13) & Chr(34)
    Set rng = doc.Paragraphs(1).Range
    rng.start = 0: rng.End = 0
    doc.Fields.Add Range:=rng, Type:=wdFieldPrint, text:=str
    
    str = "\p page " & Chr(34) & Chr(13)
    For i = 1 To outlineLastIndex - 1
        With outlines(i)
            If .level > maxOpenLevel Then
                childNum = -.childNum
            Else
                childNum = .childNum
            End If
            If debugPrint = True Then
                str = str & "% " & .name & Chr(13)
            End If
        str = str & _
            "[/Title " & .title & Chr(13) & _
            " /Count " & CStr(childNum) & Chr(13) & _
            " /Page " & CStr(.page) & Chr(13) & _
            " /View [ /FitH " & CStr(.top) & " ]" & Chr(13) & _
            " /OUT pdfmark" & Chr(13)
        End With
    Next
    str = str & Chr(34)
    i = doc.Paragraphs.Count
    Set rng = doc.Paragraphs(i).Range
    rng.start = rng.End
    doc.Fields.Add Range:=rng, Type:=wdFieldPrint, text:=str
End Sub

Sub BookmarkPdfmark()
    Dim doc As Document
    Dim para As Paragraph
    Set doc = ActiveDocument
    init doc:=doc
    For Each para In doc.Paragraphs
        putParagraph para:=para
    Next
    outBookmark doc:=doc
End Sub
----------------------------------------------------------------------
                                            tesigana@mtf.biglobe.ne.jp