指定したフォルダ内の画像ファイルを挿入するマクロ

Option Explicit

' 選択セルに指定したフォルダ内の画像ファイルを挿入

Const HEIGHT_OF_Picture As Double = 335
Const INTERVAL_ROW_OF_IAMGE As Integer = 3

Sub mainInsertPicture()

    Dim fileName As String
    Dim filePath As String
    
    Dim currentCol As Integer
    Dim currentRow As Integer
    
    Dim currentCell As Range
    Dim currentShape As Shape
    Dim shell, folderPath

    ' 現在行と列を取得
    currentCol = ActiveCell.Column
    currentRow = ActiveCell.Row
 
    ' フォルダ選択画面を表示
    Set shell = CreateObject("Shell.Application")
    Set folderPath = shell.BrowseForFolder(&O0, "タイトル : [フォルダ選択]", &H1 + &H10)
    Set shell = Nothing
    
    If Not folderPath Is Nothing Then
        
        ' 画像を読み込む
        fileName = Dir(folderPath.Items.Item.Path + "\")
        
        Do While fileName <> ""
            
            ' 拡張子が画像であれば
            If isPicture(fileName) = True Then
                filePath = folderPath.Items.Item.Path + "\" + fileName
                    
                ' 挿入先セルを選択
                Cells(currentRow, currentCol).Select
                Set currentCell = ActiveCell
                
                '選択位置に画像ファイルを挿入
                Set currentShape = ActiveSheet.Shapes.AddPicture( _
                      fileName:=filePath, _
                      LinkToFile:=False, _
                      SaveWithDocument:=True, _
                      Left:=currentCell.Left, _
                      Top:=currentCell.Top, _
                      Width:=0, _
                      height:=HEIGHT_OF_Picture)
                      
                ' 元画像と同じサイズにリサイズする
                With currentShape
'                    .ScaleHeight 1, msoTrue
                    .ScaleWidth 1, msoTrue
                End With
                
                ' 挿入行を取得
                currentRow = getRowFromHeight(currentCell, currentShape.height) + INTERVAL_ROW_OF_IAMGE
                
            End If
            
            fileName = Dir()
        
        Loop
        
        MsgBox "完了"
    
    End If
    
End Sub

' 拡張子の取得
Function getExtentionOfFile(fileName As String)
    Dim position As Integer
    
    getExtentionOfFile = ""
    
    ' 拡張子の位置を取得
    position = InStrRev(fileName, ".")
    
    ' 拡張子の取得
    If position > 0 Then
        getExtentionOfFile = Mid(fileName, position + 1)
    End If
    
End Function

' 画像拡張子の判別
Function isPicture(fileName As String)
    Dim extenetionOfFile As String
    isPicture = True
    
    extenetionOfFile = getExtentionOfFile(fileName)
    
    ' 拡張子の判定
    If extenetionOfFile <> "" Then
        Select Case LCase(extenetionOfFile)
            Case "jpeg"
            Case "jpg"
            Case "gif"
            Case "png"
            Case Else
                isPicture = False
        End Select
    Else
        isPicture = False
    End If
    
End Function

' 指定したセル位置から指定した高さを超える行を取得する
Function getRowFromHeight(targetCell As Range, height As Double)
    Dim targetRow As Long
    Dim sumOfHeight As Double
    
    sumOfHeight = targetCell.height
    targetRow = targetCell.Row
    
    Do Until sumOfHeight > height
        targetRow = targetRow + 1
        sumOfHeight = sumOfHeight + targetCell.Offset(targetRow - targetCell.Row).height
    Loop
    
    getRowFromHeight = targetRow

End Function