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