Word差し込み印刷との格闘。
友人から、施設での展示品の台帳を元に、ラベルを印刷したいという相談があった。台帳はExcelで管理されていて、1つのカラムには画像が張り付けてある。で、現時点では、Wordの差し込み印刷を利用している。で、画像も出せると思ったがうまく行かない、というのが相談。
差し込み印刷は、ExcelやWordの表データを定型形式で印刷するもの。画像は印刷できるが、ファイルパスで直接読み込む、もしくは、Wordの表で保存して、1セル内に画像ファイルが「ある」状態である必要がある。
相談時点ではExcelで、矢印とか○とかで書き込みをしてあったし、データの管理の問題もあったのでWordへの移行は却下。また、１つ１つファイルを保存するのも面倒。
ということで、提案したのが以下の通り。
全行に連番を振る。マクロで画像のあるセルを画像ファイルとして、連番.jpgという命名規則で保存する。Wordの差し込み印刷で、フォルダパス＋連番＋.jpgという形で画像の取得元を定義する。
マクロはこんな感じで書いた。
Option Explicit
'セルの画像を保存する。
Public Sub SaveImages()
Dim rg As Range
Dim cht As Chart
Dim fina As String
Dim index As Integer
index = 0
'選択範囲初期値設定
Sheets("List(L)").Activate
Range("E2").Activate
Application.ScreenUpdating = False
'値がある限り繰り返す
Do While ActiveCell.Offset(0, -4).Value <> ""
'保存ファイル名を取得
fina = CStr(ActiveCell.Offset(0, -4).Value) + ".jpg"'選択範囲を取得
Set rg = Selection
'選択した範囲を画像形式でコピー
rg.CopyPicture appearance:=xlScreen, Format:=xlPicture
'画像貼り付け用の埋め込みグラフを作成
Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
cht.Parent.Select
'埋め込みグラフに貼り付ける
cht.Paste
'JPEG形式で保存
cht.Export Filename:=fina, filtername:="JPG"
'埋め込みグラフを削除
cht.Parent.Delete
'ファイルを移動
Dim fromPath As String
Dim toPath As String
fromPath = CurDir + "\" + fina
toPath = CurDir + "\image\" + fina
'imageフォルダがなければ作成
If Dir(CurDir + "\image\", vbDirectory) = "" Then
MkDir (CurDir + "\image\")
End If
Name fromPath As toPath
'次へ
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
追記：差し込み印刷は↑のサイトがほんとにしっかり説明されています。ポイントは画像の差し込みをする際に、「完了と差し込み▼」ボタンを押した後の出力ファイルでF9を押しても画像が更新されない場合は、日本語キーボードをオフにして、F9を押して更新するという点。また、画像ファイルは絶対パスで指定しないと画像の更新がうまく行ったり、失敗したりして安定しないことがある。これはけっこうはまった。
word2010で画像を差し込み印刷のように連動させたい！ - word2010... - Yahoo!知恵袋
これはいつか使いそう。
ちょっと参考にしました。
vba-belle-equipe.hatenablog.com
