プレゼン　トラのアナ

メモ帳に下記コードを貼り付け、autopp.vbsという名前で保存します。
画像のあるフォルダにautopp.vbsを置いてダブルクリックします。
すると、そのフォルダの画像を自動スライドショーで表示します。

AutoPP1
Sub AutoPP1()
    Dim myPpt, fso
    Dim ppAp
    Dim myPP, mySd
    Dim fd, f
    Dim myH, myW
    Dim h, y, Flg
    Const myFilterName = "jpg,gif,bmp,wmf,JPG,GIF,BMP,WMF"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fd = fso.GetFolder(".")
    For Each f In fd.Files
        If InStr(1, myFilterName, Right(f.Name, 3), _
            vbTextCompare) > 0 Then
            If Not Flg Then
                Set ppAp = CreateObject("PowerPoint.Application")
                ppAp.WindowState = 2
                Set myPP = ppAp.Presentations.Add
                With myPP.SlideMaster
                    myH = .Height - 5
                    myW = .Width - 5
                End With
                Flg = True
            End If
            h = h + 1
            Set mySd = myPP.Slides.Add(h, 1)
            On Error Resume Next
            myPP.Slides.Range(h).Shapes.AddPicture f.Path, _
            False, True, 5, 5, myW, myH
        End If
    Next
    If Not Flg Then
        MsgBox ("画像ファイルが見つかりません")
        Exit Sub
    End If
    '==============スライドショーBackColor黒
    With myPP
        With .SlideMaster.Background
            .Fill.Visible = True
            ' ppForeground
            .Fill.ForeColor.SchemeColor = 2
            .Fill.Transparency = 0
            .Fill.Solid
        End With
        '==============スライドショー開始
        y = .Slides.Count + 1
        With .Slides.Range.SlideShowTransition
            .AdvanceOnClick = False
            .AdvanceOnTime = True
            '表示秒数　適当に変更して下さい
            .AdvanceTime = 2
        End With
        With .SlideShowSettings
            '繰り返し処理の有無
            '.LoopUntilStopped = True
            .AdvanceMode = 2
            .Run
        End With
        Do
            On Error Resume Next
            If .SlideShowWindow.View. _
            CurrentShowPosition = y Then Exit Do
            If Err.Number Then Exit Sub
        Loop
    End With
    Set myPP = Nothing
    ppAp.Quit
    Set fso = Nothing
End Sub