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

CSVの読み込み方法(ジャグ配列)|VBAサンプル集(7月15日)
その他のExcel機能(グループ化、重複の削除、オートフィル等)|VBA入門(7月14日)
オートフィルタ退避回復クラスを複数シート対応させるVBAクラス|VBA技術解説(7月6日)
オートフィルタを退避回復するVBAクラス|VBA技術解説(7月6日)
IfステートメントとIIF関数とMax関数の速度比較|VBA技術解説(6月23日)
Withステートメントの実行速度と注意点|VBA技術解説(6月6日)
VBA+SeleniumBasicで検索順位チェッカー(改)|VBA技術解説(6月2日)
マクロでShift_JIS文字コードか判定する|VBA技術解説(6月1日)
Shift_JISのテキストファイルをUTF-8に一括変換|VBAサンプル集(5月31日)
「VBAによる解析シリーズその2 カッコ」をやってみた|エクセル(5月21日)


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

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



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

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


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




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