セル内の値を含むサブフォルダの写真を張り付ける（ループ処理）

Question

質問です。

以下に親フォルダに含まれるサブフォルダの写真をループ処理で行順に張り付けるコードを作っています。
現状以下コードにて親フォルダ内のすべてのサブフォルダの画像を上から行順に張り付けるコードはできております。
セル(y, 2)の列にサブフォルダーの名前を入力してあるのですが、
親フォルダーのパス + セル内の値　（親フォルダーのパスはInputBoxにて入力）
のファイルパスでサブフォルダーを参照して貼り付けることは可能でしょうか。

よろしくお願いいたします。

Sub テスト写真貼り付け()

Dim alert As VbMsgBoxResult
Dim root_dir As String
Dim fso As Object
Dim sub_dirs As Object
Dim sub_dir As Object
Dim y As Long

alert = MsgBox("実行してよろしいですか？", vbYesNo + vbQuestion, "実行確認")
If alert = vbYes Then

MsgBox "親フォルダのパスを入力してください。"   '←「はい」ボタンをクリックしたときの処理。
End If

' 親フォルダのパス
root_dir = InputBox("親フォルダーのパス名の入力" + Chr(10) + "例：C:\Users\xxxx\Desktop\テスト_写真", "親フォルダー確認")

If root_dir = "" Then Exit Sub

' フォルダ内のサブフォルダをスキャン
Set fso = CreateObject("Scripting.FileSystemObject")
Set sub_dirs = fso.GetFolder(root_dir).SubFolders
y = 5
For Each sub_dir In sub_dirs

    ' このサブフォルダについて処理
    'y = importImagesFromOneSubDir(sub_dir, y, root_dir)
    Call imagesFromSubFolder(sub_dir, y)
Next

End Sub

Private Function imagesFromSubFolder(sub_dir As Object, ByRef ref_y As Long)

Dim file_name As String

'MsgBox sub_dir.Name

' このフォルダ内の画像をすべて列挙
file_name = Dir(sub_dir & "\*.*")
Do While file_name <> ""


    ' このファイルの拡張子を調べる
    If isImageFile(file_name) Then
    'If file_name <> "" Then   すべてのファイルを通す（検証用）
    
        ' 画像であれば，取り込んで次の行へ
        Call importImageFile(sub_dir & "\" & file_name, ref_y)   '//フルパスと行数を渡す
        Debug.Print ref_y & ":" & sub_dir & "\" & file_name
        
        ref_y = ref_y + 1       '参照渡しの変数をインクリメント
    End If
    
    ' 次のファイルを取得
    file_name = Dir()
Loop
    

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)
Dim file_path As String
Dim MyShape As Shape

ActiveSheet.Cells(y, 11).Select
Set MyShape = ActiveSheet.Shapes.AddPicture( _
        fileName:=file_name, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=Selection.Left + 3.4, _
        Top:=Selection.Top + 3, _
        Width:=Application.CentimetersToPoints(5.4), _
        Height:=Application.CentimetersToPoints(4.05))
    

End Sub

Comments

[meg_]

> 親フォルダ
マクロファイルがあるフォルダの上位フォルダ、という意味でしょうか？

> サブフォルダの写真
サブフォルダ内に存在する画像ファイル（jpegとか）のことでしょうか？

Answer 1

h-okhsさん

その通りです。
上記のコードは写真貼り付けやサイズ加工の確認の作業の為に動くようにしておりました。

Answer 2

上記のコードでは「親フォルダ内のすべてのサブフォルダ」から取得しているが、親フォルダ直下のセル(y,2)からのみ取得したいということでしょうか？

Set f = fso.GetFolder(root_dir & Application.PathSeparator & Cells(y,2))
Call imagesFromSubFolder(f, y)