ExcelマクロVBAサンプル集 | 写真の取込方法について(Pictures.Insert,Shapes.AddPicture) | Excelマクロの実用サンプル、エクセル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で取り込んでいます。

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

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




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

写真をサムネイルに変換して取り込む(Shapes.AddPicture)
円グラフの色設定(Chart,SeriesCollection)
棒グラフ・折れ線グラフのサンプルマクロ
人口ピラミッドのグラフをマクロで作成
グラフで特定の横軸の色を変更するマクロ
グラフのデータ範囲を自動拡張するマクロ
画像のトリミング(PictureFormat,Crop)

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

大量VlookupをVBAで高速に処理する方法について|ExcelマクロVBA技術解説(12月12日)
オセロを作りながらマクロVBAを学ぼう|ExcelマクロVBAサンプル集(11月26日)
ScreenUpdating=False時にエラー停止後にシートが固まったら|ExcelマクロVBA技術解説(11月21日)
データクレンジングと名寄せ|ExcelマクロVBA技術解説(10月20日)
SUMIFの間違いによるパフォーマンスの低下について|エクセル関数超技(6月17日)
条件式のいろいろな書き方:TrueとFalseの判定とは|ExcelマクロVBA技術解説(6月15日)
空白セルを正しく判定する方法2|ExcelマクロVBA技術解説(5月6日)
フルパスをディレクトリ、ファイル名、拡張子に分ける|ExcelマクロVBA技術解説(4月15日)
テキストボックスの各種イベント|Excelユーザーフォーム入門(4月9日)
フォルダ(サブフォルダも全て)削除する、Optionでファイルのみ削除|ExcelマクロVBAサンプル集(4月4日)

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

1.最終行の取得(End,Rows.Count)|ExcelマクロVBA入門
2.RangeとCellsの使い分け方|ExcelマクロVBA入門
3.変数とデータ型(Dim)|ExcelマクロVBA入門
4.Range以外の指定方法(Cells,Rows,Columns)|ExcelマクロVBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|ExcelマクロVBA入門
6.定数と型宣言文字(Const)|ExcelマクロVBA入門
7.マクロって何?VBAって何?|ExcelマクロVBA入門
8.CSVの読み込み方法|ExcelマクロVBAサンプル集
9.徹底解説(VLOOKUP,MATCH,INDEX,OFFSET)|エクセル関数超技
10.ひらがな⇔カタカナの変換|エクセル基本操作



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

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


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

    ↑ PAGE TOP