エクセルのマクロでコンタクトシートを作成したいです

はじめまして、
タイトルの通り、エクセルのマクロでコンタクトシートを作成したく質問しました。

コンタクトシートの内容としては、
●フォルダ内にある画像（今回の場合はPNG）すべてを一覧リスト化する（A列）。
●A列に配置された画像の情報（ファイル名、画像サイズ等）をB列以降に表示。
の以上がやりたい事です。

　　A列　　　B列　　　　C列
1　画像　ファイル名　画像サイズ
2　画像　ファイル名　画像サイズ
3　画像　ファイル名　画像サイズ
　　　　　　　・
　　　　　　　・
　　　　　　　・
と、続く様な表示にしたいです。

できれば、
A列の画像は、セルにあわせてしまうと小さく表示されてしまうようなので、
・元の画像の50％などといったように表示される？
・またはセルのサイズの最大値（50px　x　50px）を固定する？
のようになると、とてもありがたいです。

他の質問等を探してみましたが、
photoshopでのコンタクトシートは求めているものと違いました。
また、エクセル等での回答がありましたが、画像のみの表示でしたので、
上記の様な事が１度にできればと思い、ココに質問させていただきました。

知識レベルとしては、
マクロ初心者です。

どうか　みなさんの知識をお借りしたいと思いますので、
よろしくお願いいたします。

pc環境：
windows XP
Excel 2000

No.1 ベストアンサー 回答者： merlionXX 回答日時： 2011/05/12 16:16

Sub Pict_Addは、A列にPNG画像、B列にファイル名、C列に画像サイズ、D列に画像作成日　を表示させるサンプルです。

以下は、標準モジュールにコピペしてください。
下記マクロを実装したエクセルのファイルは、必ずPNG画像を置いてあるフォルダーに保存してください。
保存してから実行してください。
Sub Pict_Deleteは、表示されたデータを消去するマクロです。

Sub Pict_Add()
　　Dim myPic As Shape, myC As Range, i As Long
　　Cells.RowHeight = 50
　　Columns(1).ColumnWidth = 8.38
　　With Application.FileSearch
　　　　.NewSearch
　　　　.LookIn = ThisWorkbook.Path
　　　　.SearchSubFolders = False
　　　　.Filename = "*.png"
　　　　If .Execute() > 0 Then
　　　　　　For i = 1 To .FoundFiles.Count
　　　　　　　　Set myC = ActiveSheet.Range("A" & i)
　　　　　　　　Set myPic = ActiveSheet.Shapes.AddPicture _
　　　　　　　　(.FoundFiles(i), msoTrue, msoFalse, myC.Left, myC.Top, myC.Width, myC.Height)
　　　　　　　　myC.Offset(0, 1).Value = Dir(.FoundFiles(i))
　　　　　　　　myC.Offset(0, 2).Value = FileLen(.FoundFiles(i))
　　　　　　　　myC.Offset(0, 3).Value = FileDateTime(.FoundFiles(i))
　　　　　　Next i
　　　　End If
　　End With
　　Rows(i & ":" & Rows.Count).AutoFit
　　Columns("B:D").EntireColumn.AutoFit
End Sub

Sub Pict_Delete()
　　Dim myPic As Shape
　　For Each myPic In ActiveSheet.Shapes
　　　　If myPic.Type = msoLinkedPicture Then
　　　　　　myPic.Delete
　　　　End If
　　Next
　　Columns("B:D").ClearContents
End Sub

この回答へのお礼

merlionXX さま

回答ありがとうございます。
このマクロを実行したトコロ、問題なく、思い通りのエクセルシートが出来上がりました。
スマートな回答ありがとうございます。

この回答を実行するタイミングが遅くなり、返事が遅くなって申し訳ありませんでした。
また、質問を投稿した際に、ご縁があればまたよろしくお願いします。

お礼日時：2011/05/15 12:29