フォルダー内画像のスライドショー

Sub Excelでスライドショー()

    Const pathUser As String = "C:\Pictures"
    Const maxW As Long = 700 '最大幅 pt単位
    Const maxH As Long = 500 '最大高 pt単位
    Dim aryFile() As String 'ファイルパスの配列
    Dim i As Long
    
    '対象画像のファイルパスを配列に格納
    s_getFileArray pathUser, aryFile, 0
    'スライドショーの実行
    For i = 1 To UBound(aryFile)
        s_InsImage aryFile(i), "スライドショー", maxW, maxH
        'ユーザー操作で切り替え
        If InputBox("次の画像を表示します", "スライドショー", "続行", 500, 500) = "" Then Exit For
        '時間経過で自動切り換え
        'Application.Wait (Now + TimeValue("00:00:05"))
    Next i
End Sub

'指定フォルダー以下の画像ファイルのリストを取得する
'要参照 : Microsoft Scripting Runtime
Private Sub s_getFileArray(aPath As String, aryFile() As String, cnt As Long)

    Dim oFS As New FileSystemObject
    Dim oFile As File
    Dim oFolder As Folder
    
    'サブフォルダーの処理: 再帰呼び出し
    For Each oFolder In oFS.GetFolder(aPath).SubFolders
        f_getFileArray oFolder.Path, aryFile, cnt
    Next
    'ファイルの処理: 指定拡張子のファイルを配列に追加
    For Each oFile In oFS.GetFolder(aPath).Files
        Select Case LCase(oFS.GetExtensionName(oFile))
        Case "png", "gif", "jpeg", "jpg"
            cnt = cnt + 1
            ReDim Preserve aryFile(1 To cnt)
            aryFile(cnt) = oFile.Path
        End Select
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFS = Nothing
End Sub

'アクティブシートの画像貼り替え（スライドショー）
Private Sub s_InsImage(pathImg As String, nameShp As String, maxW As Long, maxH As Long)

    Dim oShp As ShapeRange

    Application.ScreenUpdating = False
    On Error Resume Next '未配置時のエラー回避
    ActiveSheet.Shapes(nameShp).Delete
    On Error GoTo 0
    Set oShp = ActiveSheet.Pictures.Insert(pathImg).ShapeRange
    With oShp
        .Name = nameShp
        .LockAspectRatio = True
        .Top = 30
        .Left = 10
        '最大サイズを超える場合は調整
        If .Width > maxW Then .Width = maxW
        If .Height > maxH Then .Height = maxH
    End With
    Application.ScreenUpdating = True
    
    Set oShp = Nothing
End Sub