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

[tesi...@mtf.biglobe.ne.jp]

それなりに動くものができましたので、投稿します。
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
----------------------------------------------------------------------
tesi...@mtf.biglobe.ne.jp