ExcelマクロVBAサンプル集
写真をサムネイルに変換して取り込む(Shapes.AddPicture)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2013-06-19

写真をサムネイルに変換して取り込む(Shapes.AddPicture)


写真を取り込んだ場合、リンクすると原本が無いとみられず、


リンクせずに取り込むとファイルサイズが巨大化してしまいます。


そこで、サムネイルを作成し、それをセルに貼り付け、

原本へのハイパーリンクを付けておくようにします。

写真の取込方法については、

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

こちらをご覧ください。



Sub sample()
  Dim i As Long
  Dim j As Long
  Dim ws As Worksheet
  Dim FileName As Variant
  Dim dblScal As Double
  FileName = Application.GetOpenFilename( _
    FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
    MultiSelect:=True)
  If Not IsArray(FileName) Then
    Exit Sub
  End If
  Application.ScreenUpdating = False
  Set ws = Activesheet
  j = 1
  For i = LBound(FileName) To UBound(FileName)
    'ファイル名にハイパーリンク
    ws.Hyperlinks.Add Anchor:=ws.Cells(j, 1), _
            Address:=FileName(i), _
            TextToDisplay:=FileName(i)
    '画像の取り込み
    With ws.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 ws.Cells(j, 2).Width / .Width < ws.Cells(j, 2).Height / .Height Then
        dblScal = WorksheetFunction.RoundDown(ws.Cells(j, 2).Width / .Width, 2)
      Else
        dblScal = WorksheetFunction.RoundDown(ws.Cells(j, 2).Height / .Height, 2)
      End If
      .Width = .Width * dblScal
      .Height = .Height * dblScal
      .Cut
    End With
    'サムネイルの作成
    ws.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
    With ws.Shapes(ws.Shapes.Count)
      .Top = ws.Cells(j, 2).Top
      .Left = ws.Cells(j, 2).Left
      ws.Hyperlinks.Add Anchor:=ws.Shapes(ws.Shapes.Count), Address:=FileName(i)
    End With
    j = j + 1
  Next
  ws.Select
  ws.Range("A1").Activate
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub



写真を取り込んだ後に、切り取って(Cut)、形式を選択して貼り付けて(PasteSpecial)いるだけです。


理屈としては、画像を縮小しただけでは解像度は変わりません。、

そこで、切り取り・貼り付けし直すことで、画像の解像度を落としています。

アクティブシート以外でも動作するようにしました。

ただし、最期の写真が選択状態のままになってしまうので、

指定シートに移動して、A1セルをSelectするようにしています。



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

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


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

VBAでのCSVの扱い方まとめ|VBAサンプル集(11月9日)
VBAにおける変数のメモリアドレスについて|VBA技術解説(11月8日)
空文字列の扱い方と処理速度について(""とvbNullString)|VBA技術解説(1月7日)
Errオブジェクトとユーザー定義エラー|VBA入門(11月5日)
シングルクォートの削除とコピー(PrefixCharacter)|VBA技術解説(11月4日)
ユーザー定義型の制限とクラスとの使い分け|VBA技術解説(11月3日)
クリップボードに2次元配列を作成してシートに貼り付ける|VBA技術解説(11月1日)
VBAクラスを使ったイベント作成(Event,RaiseEvent,WithEvents)|VBA技術解説(10月31日)
VBAクラスのAttributeについて(既定メンバーとFor Each)|VBA技術解説(10月19日)
VBAの用語について:ステートメントとは|VBA技術解説(10月16日)


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

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



  • >
  • >
  • >
  • 写真をサムネイルに変換して取り込む(Shapes.AddPicture)

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


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




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