写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

最終更新日：2013-05-28

写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

写真を取り込んで、アルバムのようにしたり、

各種の資料を作ったりと、写真をエクセルに取り込む機会は多いようです。

しかし、最近は写真のサイズも大きくなり、

手動で取り込んだままではスクロールもままならない状態となってしまいます。

そこで、写真ファイルを指定し、A列に上から順番に貼り付け、

さらにセル内に収まるように縮小するマクロになります。

まずは、マクロの記録でも使われている
Pictures.Insert
を使って

Sub sample1()
　　Dim i As Long
　　Dim j As Long
　　Dim FileName As Variant
　　Dim dblScal As Double
　　Dim sp As Shape
　　FileName = Application.GetOpenFilename( _
　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
　　　　MultiSelect:=True)
　　If Not IsArray(FileName) Then
　　　　Exit Sub
　　End If
　　For Each sp In ActiveSheet.Shapes
　　　　If sp.TopLeftCell.Column = 1 Then
　　　　　　sp.Delete
　　　　End If
　　Next
　　j = 1
　　For i = LBound(FileName) To UBound(FileName)
　　　　Cells(j, 1).Select
　　　　With ActiveSheet.Pictures.Insert(FileName(i))
　　　　　　'サイズ調整、セル内に収める
　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then
　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)
　　　　　　Else
　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)
　　　　　　End If
　　　　　　.Width = .Width * dblScal '縦横比を維持して縮小される
　　　　End With
　　　　j = j + 1
　　Next i
End Sub

これで、とりあえず、ちゃんと貼りつきました。

しかし、元ファイルが、取り込んだ時のフォルダーに存在しないと表示できません。

これは不都合です。

エクセルファイルを配布できません。

以下では、写真をリンクではなくエクセルに貼り付けています。

Shapes.AddPicture
を使ってリンクせずに取込

Sub sample2()
　　Dim i As Long
　　Dim j As Long
　　Dim FileName As Variant
　　Dim dblScal As Double
　　Dim sp As Shape
　　FileName = Application.GetOpenFilename( _
　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
　　　　MultiSelect:=True)
　　If Not IsArray(FileName) Then
　　　　Exit Sub
　　End If
　　For Each sp In ActiveSheet.Shapes
　　　　If sp.TopLeftCell.Column = 1 Then
　　　　　　sp.Delete
　　　　End If
　　Next
　　j = 1
　　For i = LBound(FileName) To UBound(FileName)
　　　　Cells(j, 1).Select
　　　　With ActiveSheet.Shapes.AddPicture( _
　　　　　　　　FileName:=FileName(i), _
　　　　　　　　LinkToFile:=False, _
　　　　　　　　SaveWithDocument:=True, _
　　　　　　　　Left:=Selection.Left, _
　　　　　　　　Top:=Selection.Top, _
　　　　　　　　Width:=0, _
　　　　　　　　Height:=0)
　　　　　　'一旦、元のサイズに戻す
　　　　　　.ScaleHeight 1, msoTrue
　　　　　　.ScaleWidth 1, msoTrue
　　　　　　'サイズ調整、セル内に収める
　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then
　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)
　　　　　　Else
　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)
　　　　　　End If
　　　　　　.Width = .Width * dblScal
　　　　　　.Height = .Height * dblScal
　　　　End With
　　　　j = j + 1
　　Next i
End Sub

Shapes.AddPictureでの取込時点では、サイズが不明なので、
Width:=0
Height:=0)
で、サイズ0で取り込んでいます。

その後、一旦、元のサイズに戻した後に、セル内に収めています。

写真そのものがエクセルに貼りついていますので、エクセルのサイズは当然大きくなります。

同じテーマ「マクロVBAサンプル集」の記事

図を確認しながら消していく（Shape）
オートシェイプを他ブックの同じ位置に貼り付ける（Shapes,DrawingObjects）
全シートの画面キャプチャを取得する（keybd_event）
写真の取込方法について（Pictures.Insert,Shapes.AddPicture）
写真をサムネイルに変換して取り込む（Shapes.AddPicture）
円グラフの色設定（Chart,SeriesCollection）
棒グラフ・折れ線グラフのサンプルマクロ
 人口ピラミッドのグラフをマクロで作成
 グラフで特定の横軸の色を変更するマクロ
 グラフのデータ範囲を自動拡張するマクロ
 画像のトリミング（PictureFormat,Crop）

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.変数とデータ型（Dim）｜ExcelマクロVBA入門
3.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
4.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
5.マクロって何？VBAって何？｜ExcelマクロVBA入門
6.RangeとCellsの使い方｜ExcelマクロVBA入門
7.とにかく書いて見よう（Sub,End Sub）｜VBA入門
8.繰り返し処理（For Next)｜ExcelマクロVBA入門
9.定数と型宣言文字（Const）｜ExcelマクロVBA入門
10.マクロはどこに書くの（VBEの起動）｜VBA入門

トップ >

マクロVBA >

マクロVBAサンプル集 >

写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
なお、掲載のVBAコードは自己責任で使ってください。万一データ破損等の損害が発生しても責任は負いません。

ExcelマクロVBAサンプル集 | 写真の取込方法について（Pictures.Insert,Shapes.AddPicture） | ExcelマクロVBAの実用サンプル、エクセルVBA集と解説