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 ・・・新着記事一覧を見る

トランザクション処理|SQL入門(12月11日)
インデックスを作成して高速化(CREATE INDEX)|SQL入門(12月9日)
他のテーブルのデータで追加/更新/削除|SQL入門(12月8日)
データの削除(DELETE)|SQL入門(12月7日)
データの更新(UPDATE)|SQL入門(12月6日)
複数のSELECT結果を統合(UNION,UNION ALL)|SQL入門(12月5日)
テーブルを結合して取得(INNER JOIN,OUTER JOIN)|SQL入門(12月4日)
データベースの正規化とマスタの作成|SQL入門(12月3日)
データベースにおけるNULLの扱い方|SQL入門(12月2日)
オブジェクト変数とは何か|VBA技術解説(12月2日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.RangeとCellsの使い方|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.ひらがな⇔カタカナの変換|エクセル基本操作



  • >
  • >
  • >
  • 写真の取込方法について(Pictures.Insert,Shapes.AddPicture)

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


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



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