PowerPoint のスライド毎に画像を貼り付けていくマクロ

  数百枚ある写真を 1 枚 1 枚 PowerPoint に貼り付けていくという気の遠くなる作業を頼まれたので作成．

Option Explicit

Public Sub addPhotoParPage()

    Dim i As Integer
    Dim strPath As String

    Dim objFileSystem As Object
    Dim objFolder As Object
    Dim objFile As Object

    strPath = BrowseForFolder()

    If strPath = "" Then
        Exit Sub
    End If

    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFileSystem.GetFolder(strPath)

    i = 0
    For Each objFile In objFolder.Files
        ' スライドの追加
        ActivePresentation.Slides.Add( _
            Index:=ActivePresentation.Slides.Count + 1, _
            Layout:=ppLayoutText).Select
        ' 画像の挿入
        ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
            FileName:=objFile.Path, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, _
            Top:=0).Select
        ' 50 回に一回 DoEvents 発生
        i = i + 1
        If i Mod 50 = 0 Then
            DoEvents
        End If
    Next

    Set objFile = Nothing
    Set objFolder = Nothing
    Set objFileSystem = Nothing

End Sub

Private Function BrowseForFolder(Optional varRoot As Variant) As String

    Dim objFolder As Object

    ' フォルダ選択ダイアログを表示
    Set objFolder = CreateObject("Shell.Application").BrowseForFolder( _
                                 0, _
                                 "画像があるフォルダを選択してください", _
                                 &H11, _
                                 varRoot)

    ' 選択内容を取得
    If Not (objFolder Is Nothing) Then
        BrowseForFolder = objFolder.Items.Item.Path
    Else
        BrowseForFolder = ""
    End If

    Set objFolder = Nothing

End Function