表題の通り、あるフォルダの直下に複数のフォルダがあり、その中にランダムな枚数、大きさで写真データが入っています。
写真が入っているフォルダが物件になるので、フォルダ単位でシートを作成してそこに写真を同じ大きさで張付けるマクロを作成したいと思い、色々ネット上を検索してみて、サブフォルダの写真を一括で1シートに並べる物は見つかったのですが、そこにどう追記をすれば良いのかがわかりません。
お力をお借りできればと思い書き込みさせてもらいました。
ソースは以下です。よろしくお願いします。
' 指定された親フォルダ内で,すべてのサブフォルダ内に存在する
' 画像のサムネイルのアルバムをシート上に作成します。
Sub CreateImgAlbum()
' 親フォルダのパス root_dir = "" ' フォルダ内のサブフォルダをスキャン 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 isImageFile = ret
End Function
' ある一つの画像ファイルをシート中に取り込む
Private Sub importImageFile(file_name, y, root_dir, sub_dir)
file_path = sub_dir & "" & file_name
ActiveSheet.Cells(y, 1).Select Set myShape = ActiveSheet.Shapes.AddPicture( _ Filename:=file_path, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=Selection.Left, _ Top:=Selection.Top, _ Width:=Application.CentimetersToPoints(10), _ Height:=Application.CentimetersToPoints(7)) ' この行高を自動調整 Cells(y, 1).RowHeight = Application.CentimetersToPoints(7.3)
End Sub
回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2018/10/23 06:15
2018/10/23 06:20