エクセルのデーターベースに写真を取り入れる方法を教えてください

質問

エクセルで写真付社員カードを作成したいと思っています。
約２３０名分です。

１行に名前、所属等のデーターを入力し、
ＶＢＡを使って、印刷用の画面にそれぞれ自動で流し込み印刷するように、まではできたのです。
写真を自動で、どのように貼り付けたら良いかがわかりません。

データー入力行の中に、写真データーも入れて、自動ですべての社員を順次、印刷させたいのです。
写真をデーター行の中に貼り付けると、やたら大きくなってしまいます。
写真を自動で流しこみする方法もわかりません。

どのようにしたらうまくいくのでしょうか？
すみませんが教えてください。
よろしくお願いします。

回答No.1

papayuka · ベストアンサー

> ＶＢＡを使って、印刷用の画面にそれぞれ自動で流し込み印刷するように、まではできたのです。

そのソースに画像を入れるコードを入れれば良いのでは無いでしょうか？
例えば、
1）新規ブックの標準モジュールに下記をコピペして画像があるフォルダに「保存（必ず）」します。
2）同フォルダに指定ファイルが見つからない場合用の画像「NoImage.jpg」を用意します。
3）アクティブシートのA1に画像ファイル名（123.jpg なら 123）を入れて実行すると画像が表示されます。

Sub Test()
Dim fName As String, pict As Shape
On Error GoTo ER:
　With ActiveSheet
　fName = ThisWorkbook.Path & "\" & .Range("A1").Value & ".jpg"
　If Dir(fName) = "" Then
　　 fName = ThisWorkbook.Path & "\NoImage.jpg"
　End If

　　For Each pict In .Shapes
　　　If pict.TopLeftCell.Address = "$C$1" Then
　　　　 pict.Delete
　　　　 Exit For
　　　End If
　　Next pict
　　Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _
　　　　　　　 .Range("C1").Left, .Range("C1").Top, 320, 240)
　End With
ER:

End Sub

回答No.2

KenKen_SP

こんにちは。KenKen_SP です。

AddPicture で画像を埋め込む方法もありますが、差込印刷用途だとブック
が不必要に肥大化する可能性がありますね...コントロールを使ってみたら？

[表示]-[コントロール ツールボックス] の Image コントロールを印刷用の
シートに任意の大きさで配置します。このコントロールの大きさが印刷時の
大きさになります。

この方法の２次的なメリットは、画像サイズがバラバラでも Image コント
ロールが自動で拡縮してくれることでしょうか。

下記のサンプルコードの内、※記号の部分は Image コントロールの初期化を
行っているだけですから、プロパティーウインドウで設定した場合は不要です。

Sub Sample()

　　Dim PicCtrl　　 As Image
　　Dim PicFilepath As String

　　Set PicCtrl = Worksheets("Output").Image1

　　' ※ Image コントロール初期化
　　With PicCtrl
　　　　.BackColor = RGB(255, 255, 255)　　　　　　　 ' 背景色 &HFFFFFF（白）
　　　　.BorderStyle = fmBorderStyleNone　　　　　　　' 境界線なし
　　　　.PictureAlignment = fmPictureAlignmentCenter　' 画像配置位置 センター
　　　　.PictureSizeMode = fmPictureSizeModeZoom　　　' 縦横比を保持して枠内最大表示
　　End With

　　' データシートからファイルパスを取得
　　PicFilepath = Worksheets("Data").Range("A1").Value

　　' Image コントロールに画像を表示
　　If Dir$(PicFilepath) = "" Then
　　　　' パス未設定またはファイルが存在しない場合
　　　　PicCtrl.Picture = Nothing
　　Else
　　　　PicCtrl.Picture = LoadPicture(PicFilepath)
　　End If

End Sub