VBAサンプル集
写真の取込方法について(Pictures.Insert,Shapes.AddPicture)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日: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)


新着記事NEW ・・・新着記事一覧を見る

ツイッターで出されたVBAのお題をやってみた|エクセル雑感(1月13日)
イベントプロシージャーの共通化(Enter,Exit)|ユーザーフォーム入門(1月13日)
Rangeオブジェクトの論理演算(差集合と排他的論理和)|VBA技術解説(1月10日)
イベントプロシージャーの共通化|ユーザーフォーム入門(1月7日)
コントロールの動的作成|ユーザーフォーム入門(1月6日)
Evaluateメソッド(文字列の数式を実行します)|VBA技術解説(1月5日)
エクスポート(PDF/XPS)|VBA入門(1月2日)
分析関数(OVER句,WINDOW句)|SQL入門(12月25日)
取得行数を限定するLIMIT句|SQL入門(12月21日)
外部ライブラリ(ActiveXオブジェクト)|VBA入門(12月21日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
5.変数宣言のDimとデータ型|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.マクロって何?VBAって何?|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.空白セルを正しく判定する方法(IsEmpty,IsError,HasFormula)|VBA技術解説
10.ひらがな⇔カタカナの変換|エクセル基本操作




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


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



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