【VBA】Excelにフォルダ内の画像一覧を作る方法

Sub JIKKOU2()

    Dim RowN As Integer
    
    ''エクセルシート上で選択した範囲内の全ての図形を削除する

    Set select_range = Range(Cells(6, 1), Cells(10000, 4))
    select_range.ClearContents
    If ActiveSheet.Shapes.Count > 2 Then
        For i = ActiveSheet.Shapes.Count To 1 Step -1
            With ActiveSheet.Shapes(i)
                Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
                If Not Intersect(shp_rng, select_range) Is Nothing Then
                    ActiveSheet.Shapes(i).Delete
                End If
            End With
        Next i
    End If
        
    Application.ScreenUpdating = False '画面更新をOFF
    Application.Calculation = xlManual '自動計算をOFF
    Application.EnableEvents = False 'イベントをOFF
    
    LASTY = Cells(Rows.Count, 2).End(xlUp).Row '1を任意に替える
        
    Call searchPic(Cells(3, 4), 6) '←検索したいフォルダを指定する。ColNは張り付け始める位置。
         
    Application.ScreenUpdating = True '画面更新をON
    Application.Calculation = xlAutomatic '自動計算をON
    Application.EnableEvents = True 'イベントをON
     
End Sub
  
Sub searchPic(PATH As String, ColN As Integer)
    Dim buf As String, childf As Object
 
'フォルダ内全部
    buf = Dir(PATH & "\*.png")
   
    Do While buf <> ""
     
        Cells(ColN, 1).Value = ParentDirName(PATH)
        Cells(ColN, 2).Value = buf
        Cells(ColN, 3).Activate
       '名前が一致したら実行するように指示。
       
        myFileName = PATH & "\" & buf
         
        '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
        Set myShape = ActiveSheet.Shapes.AddPicture( _
              Filename:=myFileName, _
              LinkToFile:=True, _
              SaveWithDocument:=False, _
              Left:=Selection.Left + 1, _
              Top:=Selection.Top + 1, _
              Width:=0, _
              Height:=0)
              
        '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
        With myShape
            .ScaleHeight 1.5, msoTrue
            .ScaleWidth 1.5, msoTrue
        End With
            
        ColN = ColN + 1
        
       
       '次のファイル
           buf = Dir()
    Loop
     
    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(PATH).SubFolders
            Call searchKatashiki(childf.PATH, ColN)
        Next
    End With
     
End Sub


Function ParentDirName(PATH As String) As String

    ParentDirName = Left(PATH, InStrRev(PATH, "\") - 1)
    ParentDirName = Mid(ParentDirName, InStrRev(ParentDirName, "\") + 1)
    


'  With ThisWorkbook
'    ParentDirName = Left(ParentDirName, InStrRev(ParentDirName, "\") - 1)
'  End With


End Function