用紙サイズとPDFファイルのみでWord差込印刷イメージを作成する

はじめに

事務の現場では頻繁に金融機関の伝票、行政の申請書、会社独自の封筒、といった「紙に印刷された様式」に遭遇します。

月１で使う様式が20種、30種なんてことも。。。

既存の紙様式にプリントするためのフォームを作ろうと思うと、用紙の端から記載欄までの寸法とかを測って

テキストボックス配置→印字→調整→印字→・・・の繰り返し。

結局手書きの方が早かった。なんてことになります。
（でも、書き損じが面倒なので手書きは嫌いです。）

目的

すでに印刷されている紙様式に後から差込プリントしたい。

その際のフォーム作成にかかる時間を短縮する。

処理フロー

1.紙様式をスキャンして同じサイズのPDFにする（ダウンロードしたPDFでもOK）

2.紙様式と同じサイズのWordドキュメントを作成する

3.Wordオプションで隠し文字を「印字しない」設定にする

4.Wordドキュメントのヘッダーの先頭文字入力位置を隠し文字に設定する

5.ヘッダーの先頭文字入力位置に行内のOLEオブジェクトとしてPDFを挿入する

6.OLEオブジェクトのサイズをページサイズに合わせる

7.差込用テキストボックスをいい感じで配置する（※自力で）

・・・以上！たった7ステップ！

**サンプルコード**

'Word、Acrobat Reader　要インストール

'PageHeight, PageWidth はミリメートル指定（内部でポイント変換処理）
Sub CreateMergeImageDocument(ByVal PageWidth As Single, ByVal PageHeight As Single, ByVal FilePath As String)

'引数のチェック(ページサイズは15mm～550mmの間で指定)※12.7mm未満558.8mm以上はエラー
If (PageWidth < 15) Or (PageWidth > 550) Then MsgBox "ページサイズは15mm～550mmの間で指定してください。":   Exit Sub
If (PageHeight < 15) Or (PageHeight > 550) Then MsgBox "ページサイズは15mm～550mmの間で指定してください。": Exit Sub
If (Dir(FilePath) = "") Then MsgBox "ファイルが存在しません。": Exit Sub

'実行確認
If MsgBox("処理を開始しますか？", vbOKCancel, "印刷イメージフォーム作成 ") <> vbOK Then Exit Sub

'エラートラップ
On Error GoTo ErrNum

'Wordを起動して新規文書作成
'Dim WordApp As Word.Application: Set WordApp = New Word.Application: WordApp.Visible = True
'Dim WordDoc As Word.Document:    Set WordDoc = WordApp.Documents.Add
Dim WordApp As Object: Set WordApp = CreateObject("Word.Application"): WordApp.Visible = True
Dim WordDoc As Object: Set WordDoc = WordApp.Documents.Add

'ミリ指定ページサイズをポイントに変換
Dim PointHeight As Single: PointHeight = WordApp.MillimetersToPoints(PageHeight)
Dim PointWidth As Single:  PointWidth = WordApp.MillimetersToPoints(PageWidth)

'表示倍率100％、隠し文字を常に表示&印刷しない
WordApp.ActiveWindow.View.Zoom = 100
WordApp.ActiveWindow.View.ShowHiddenText = True
WordApp.Options.PrintHiddenText = False

With WordDoc
    'ページ設定
    With .PageSetup
        .HeaderDistance = 0
        .FooterDistance = 0
        .TopMargin = 0
        .RightMargin = 0
        .BottomMargin = 0
        .LeftMargin = 0
        .PageWidth = PointWidth
        .PageHeight = PointHeight
    End With
    
    'ヘッダーの文字入力位置
'    Dim HeaderRange As Word.Range: Set HeaderRange = .Sections.First.Headers(1).Range
    Dim HeaderRange As Object: Set HeaderRange = .Sections.First.Headers(1).Range
    
    '隠し文字に設定
    HeaderRange.Font.Hidden = True

    'ヘッダーに「行内」のシェイプを挿入しサイズをページサイズに変更（jpg以外はOLEObjectで作成）
    With .InlineShapes
        If FilePath Like "*.jpg" Then
            With .AddPicture( _
                    Filename:=FilePath, _
                    LinkToFile:=False, _
                    Range:=HeaderRange)
                .Width = PointWidth
                .Height = PointHeight
            End With
        Else
            With .AddOLEObject( _
                    Filename:=FilePath, _
                    LinkToFile:=False, _
                    Range:=HeaderRange)
                .Width = PointWidth
                .Height = PointHeight
            End With
        End If
    End With
            
    'フォーム用テキストボックスの挿入・書式設定（コピペ用）:msoTextOrientationHorizontal = 1
    With .Shapes.AddTextbox( _
        Orientation:=1, _
        Left:=WordApp.MillimetersToPoints(10), _
        Top:=WordApp.MillimetersToPoints(10), _
        Width:=WordApp.MillimetersToPoints(40), _
        Height:=WordApp.MillimetersToPoints(20))

        With .TextFrame
            .AutoSize = True
            .MarginTop = 0
            .MarginRight = 0
            .MarginBottom = 0
            .MarginLeft = 0
            .TextRange.Text = "このテキストボックスをコピーしてフォームを作成します。" & vbCrLf & _
                              "フォント・文字の大きさ・装飾等はお好みで変更してください。"
        End With
        
        '枠線を非表示
        .Line.Visible = msoFalse
        
        'ページ基準へ配置設定: wdRelativeHorizontalPositionPage = 1 , wdRelativeeVerticalPositionPage = 1
        .RelativeHorizontalPosition = 1
        .RelativeVerticalPosition = 1
    End With
End With

'ExcelVBAからの参照破棄（ワードは起動したままになる）
Set WordDoc = Nothing
Set WordApp = Nothing

'終了通知
MsgBox "印刷イメージフォームを作成しました。"
Exit Sub

ErrNum:
MsgBox "エラーにより処理を中断しました。"
If Not (WordDoc Is Nothing) Then WordDoc.Close SaveChanges:=False
If Not (WordApp Is Nothing) Then WordApp.Quit SaveChanges:=False
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

解説

ポイントはWordのシェイプオブジェクトのレイアウトのうち**「行内」に設定したときに隠し文字属性が適用される**ことです。（Word.InlineShapesオブジェクト）

これによって、ドキュメント編集中はPDFが背景のように表示され、印刷イメージのようにテキストボックスを配置できますが、PDFのイメージは印刷はされません。

補足

処理の性質上、プリンターに通せるあらゆる紙様式に対応できます。が、印字調整の確認は必要です。

Wordファイルなので、エクセルからの差し込み印刷も可能です。

PDF背景の場合、若干表示が荒くなりますが、PDFをjpgに変換してファイル指定するときれいに見えます。

PDF以外でも「挿入」の「オブジェクトの挿入」で表示されるファイルはOLEオブジェクトとして指定が可能です。

印字調整後、ヘッダー内のOLEオブジェクトを削除するとファイルサイズが小さくなります。

Word以外のVBAでも動きます。（Excelで用紙とかファイルとか取得させたかったので、引数要求する仕様にしています。）

最後に

事務屋にとってはExcel・Wordはまだまだ生命線です。（というか職場にそれくらいしかないし）