スポンサーリンク

Excel VBAで,フォルダ内の画像ファイルを一括でシートに取り込み,サムネイルのアルバムを自動生成


Excelブック内に,画像の「サムネイル集」を作りたいとしよう。


親フォルダの中に,サブフォルダがたくさんあり,

サブディレクトリの中には画像がたくさんある。


それらの画像のサムネイルを,サブフォルダの名前と共に並べて列挙したい。


そういう場合,Excel VBAのマクロでは,下記のような処理が関係してくる。

  • ある親フォルダ内の子フォルダを,すべてスキャンして取得する。
  • あるフォルダ内の画像ファイルを,すべてスキャンして取得する。
  • 画像ファイルを,特定のサイズで,シート内に埋め込む。
  • シートの行や列の高さを調整する。

これらの条件をすべて満たすようなサンプルコードを,下記に掲載する。


VBAサンプルコード

親フォルダの場所と,画像ファイルの拡張子について書いてある部分は,必要に応じて書き換える。

画像のサムネイルは,縦横比を無視してヨコ6cm×タテ1cmで貼り付けられる。

画像が格納されているサブフォルダの名称が隣りに併記される。

' 指定された親フォルダ内で,すべてのサブフォルダ内に存在する
' 画像のサムネイルのアルバムをシート上に作成します。
Sub CreateImgAlbum()
    
    ' 親フォルダのパス
    root_dir = "D:\temp\"
    
    ' フォルダ内のサブフォルダをスキャン
    ' http://www.k1simplify.com/vba/tipsleaf/leaf270.html
    ' http://officetanaka.net/excel/vba/filesystemobject/folder14.htm
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sub_dirs = fso.GetFolder(root_dir).SubFolders
    y = 1
    For Each sub_dir In sub_dirs
        ' このサブフォルダについて処理
        y = importImagesFromOneSubDir(sub_dir, y, root_dir)
    Next
    
    ' 1列目の幅を自動調整
    Rows(1).EntireColumn.AutoFit
    
    
    MsgBox "全サブフォルダの処理を終了"
    
End Sub


' ある一つのサブフォルダについての処理
Private Function importImagesFromOneSubDir(sub_dir, y, root_dir)
    'MsgBox sub_dir.Name
    
    ' このフォルダ内の画像をすべて列挙
    file_name = Dir(sub_dir & "\*.*")
    Do While file_name <> ""
        ' このファイルの拡張子を調べる
        If isImageFile(file_name) Then
            ' 画像であれば,取り込んで次の行へ
            importImageFile file_name, y, root_dir, sub_dir
            y = y + 1
        End If
        
        ' 次のファイルを取得
        file_name = Dir()
    Loop
        
    ' 現在の行を返す
    importImagesFromOneSubDir = y
    
End Function
        

' 画像ファイルかどうか,拡張子で判定する
Private Function isImageFile(file_name)
    
    ' ピリオドは後ろから何文字目か
    pos_period = InStrRev(file_name, ".")
    If pos_period > 0 Then
        ' 拡張子を切り出し
        file_ext = LCase(Mid(file_name, pos_period + 1))
        
        ' 画像の拡張子か?(小文字で指定可)
        If _
            file_ext = "jpg" Or _
            file_ext = "jpeg" Or _
            file_ext = "bmp" Or _
            file_ext = "gif" Or _
            file_ext = "png" _
        Then
            ' 画像であると判定
            ret = True
        Else
            ret = False
        End If
    Else
        ret = False
    End If
    ' http://officetanaka.net/excel/vba/tips/tips57.htm
    
    isImageFile = ret
End Function


' ある一つの画像ファイルをシート中に取り込む
Private Sub importImageFile(file_name, y, root_dir, sub_dir)
    file_path = sub_dir & "\" & file_name
    
    ' 一列目にはサブフォルダ名を
    ActiveSheet.Cells(y, 1).Value = sub_dir.Name
    
    ' 二列目には画像を
    ActiveSheet.Cells(y, 2).Select
    Set myShape = ActiveSheet.Shapes.AddPicture( _
          Filename:=file_path, _
          LinkToFile:=False, _
          SaveWithDocument:=True, _
          Left:=Selection.Left, _
          Top:=Selection.Top, _
          Width:=Application.CentimetersToPoints(6), _
          Height:=Application.CentimetersToPoints(1))
        ' http://www.moug.net/tech/exvba/0120020.html
        ' http://www.moug.net/tech/exvba/0070012.html
    
    ' この行高を自動調整
    Cells(y, 1).RowHeight = Application.CentimetersToPoints(1)

End Sub

参考資料と補足

下記は,コーディングのために参考にしたページ。


フォルダ内のサブフォルダの一覧の取得について:

Office TANAKA - Excel VBA FileSystemObject[SubFoldersプロパティ]
http://officetanaka.net/excel/vba/fil...

  • Folder.SubFolders


Excel VBA 指定ディレクトリ内のフォルダ名を表示(その2) - Gブログ
http://d.hatena.ne.jp/bhunji2000/2009...

  • FileSystemObjectオブジェクトからサブフォルダのFolderオブジェクトを取得し、そこからサブフォルダ名を取得


Office TANAKA - Excel VBA Tips[Dir関数でサブフォルダを取得する]
http://officetanaka.net/excel/vba/tip...

  • Dir関数は引数に指定したファイルが存在したとき、そのファイル名を返す関数。引数にはワイルドカードを指定可能
  • 引数にどんな定数を指定しても、常に「標準ファイル」は指定されていることになるので,サブフォルダの取得の用途には向かない。どうしてもやりたい場合は,vbDirectory定数とGetAttr関数を併用する


File / Folder の一覧を取得する - アプリケーションとしてのVBA
http://www.k1simplify.com/vba/tipslea...

  • Scripting.FileSystemObjectでフォルダオブジェクトのコレクションを取得する方法が一番楽


フォルダ内のファイルスキャンについて(複数のファイル形式を許容するマッチング):

Dir
http://homepage2.nifty.com/kasayan/vb...

  • Dir関数は、ファイル名やフォルダ名を取得したい場合に使用。Visual basic, Excel(VBA)ともにまったく同様に使用することができる。
  • Dirの使い方は、最初のファイルのマッチング(検索)には、必ずFileSpecを記述して使い、2個目以降はFileSpec等は省略し、Dir単独で使う。マッチングするファイルが見つからない時はNullが返される


DIR関数を使ったファイル名の取得 | Visual BasicのQ&A【OKWave】
http://okwave.jp/qa/q273683.html

  • 複数の形式のファイル名を同時に取得する方法はあるのか→取得したファイル名から、IF文で、拡張子を抽出すればよい


24640-0 | DIR命令での複数拡張子指定 - VB初心者友の会 - Q&A掲示板過去ログ
http://www.gizcollabo.jp/vbtomo/log/a...

  • DIR関数だけだと,ループを複数回やるしかない


Office TANAKA - Excel VBA Tips[拡張子を判定する方法]
http://officetanaka.net/excel/vba/tip...

  • ピリオドの位置を調べて、そこから後ろを抜き出して判定する


ファイル名から拡張子を取得する - GetExtensionName [Scripting.FileSystemObject] - VBScript Tips [VBA/Access/Excel対応]
http://www.happy2-island.com/vbs/cafe...

  • GetExtensionNameメソッドを使う手もある


画像を「センチメートル」単位でサイズ指定して,シート内に貼り付ける:

画像ファイルを挿入する:Excel VBA|即効テクニック|Excel VBAを学ぶならmoug
http://www.moug.net/tech/exvba/012002...

  • LinkToFile:元のファイルとのリンクを設定するか
  • SaveWithDocument:画像をExcelファイルとともに保存するか


【EXCEL VBA】指定フォルダにある画像をまとめて貼り付けるマクロ | Programmer's EGG
http://programlife.jugem.jp/?eid=48

  • BrowseForFolderのダイアログでフォルダを選択するサンプルコード


Excel VBA を学ぶなら moug モーグ | 即効テクニック | 余白を設定する
http://www.moug.net/tech/exvba/007001...

  • マクロ記録時には、センチメートル単位で設定したものが、ポイント単位に変換された結果の数値で記録される。プログラムの可読性や後々の仕様変更を考えれば、CentimetersToPointsメソッドを使用して書きなおした方がよい


Office TANAKA - Excel VBA Tips[セルのコメントに画像を表示する]
http://officetanaka.net/excel/vba/tip...

  • Excel内で通常利用される長さの単位はポイント
  • センチメートルで指定したものをExcelが理解できるようにポイントに変換するには、ApplicationオブジェクトのCentimetersToPointsメソッドを使う


行の高さと列の幅の自動調整について:

[excel][vba]行の高さを自動調整するマクロ その1 : レスペス・トランクィル
http://blog.livedoor.jp/qoozy/archive...

  • シート全体の行を自動調整:Selection.EntireRow.autofit


【Excel VBA サンプル集】行の高さ・列の幅を自動調整する - ExcelVBA@Workshop
http://excel.style-mods.net/tips_vba/...

  • 行の高さを自動調整:.Rows.AutoFit
  • 列の幅を自動調整:.Columns.AutoFit


How to Autofit Column Widths with VBA » Vergel’s Excel and Visual Basic Blog
http://www.vadriano.com/excel-vb/2007...

  • ActiveSheet.UsedRange.Rows.AutoFit
補足

この記事は,下記の質問への回答として執筆させて頂きました。

Excel VBA のコードをお願いいたします。 ?.自動でB列に画像フ..
http://q.hatena.ne.jp/1383824213



関連する記事:

ドキュメント作成を楽にするための,Excel VBA 頻出8パターン
http://language-and-engineering.hatenablog.jp/entry/20090401/p1


VBA(2007もOK)で,ファイルの再帰検索をしよう (Application.FileSearchで複数のブックを処理)
http://language-and-engineering.hatenablog.jp/entry/20090429/p1


Excel VBAで,グラフを自動で描画しよう(データ範囲を動的に変える) + ソフトウェアの品質保証について
http://language-and-engineering.hatenablog.jp/entry/20090516/p1