【PowerPointVBA】画像を挿入して整列

Option Explicit

Public Sub 複数画像を一括選択して整列()
    '①指定フォルダから現在選択しているスライドに対して複数画像を挿入
    Dim stPath As String
    stPath = SelectFolderInBrowser("C:\")
    
    'フォルダが選択されていなければ終了
    If stPath = "" Then
        Exit Sub
    End If

    'ファイルシステムオブジェクト群を生成
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim oFolder As Object
    Set oFolder = FSO.GetFolder(stPath)
    
    Dim f As Object
    Dim Shp As Shape
    
    'スライドのサイズ
    Dim singleSlideWidth As Single '元ネタはInteger型にしていたけど、調べたらSingle型なので修正
    singleSlideWidth = ActivePresentation.PageSetup.SlideWidth
    Dim singleSlideHeight As Single 'Integer
    singleSlideHeight = ActivePresentation.PageSetup.SlideHeight
    
    '貼り付ける画像のサイズ
    Dim iImageWidth As Single
    Dim iImageHeight As Single
    
    '画像データの横に並べる数
    Const csingleClmCnt As Single = 2 'これはLong型でもInteger型でもよかったが、計算式で使うとき他の変数がすべてSingleなのでこれもSingle型に
    
    '画像データ配置時の隙間指定
    Const csingleMarginSlideEdge As Single = 25 '元ネタはDimとしていたけど使い方を見たらConstだったので変更
    Const csingleMarginImage As Single = 5
    
    'マージンの演算
    Dim iMarginTotal As Single
    iMarginTotal = csingleMarginSlideEdge * 2 + csingleMarginImage * (csingleClmCnt - 1)
    
    'JPEG画像のサイズ
    Dim singleJpegWidth As Single
    Dim singleJpegHeight As Single
    
    'JPEG画像の(最終的な)位置
    Dim singleJpegLeft As Single
    
    'フォルダ配下にJPEGファイルが1つとPNGファイルが複数入っているという前提
    '②jpgファイルだけ別サイズ，位置で配列．
    '最初にJPEGファイルを探す
    For Each f In oFolder.Files

        Select Case LCase(FSO.GetExtensionName(f.Path))
        Case "jpg", "jpeg"
            '画像を挿入
            Set Shp = ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
                FileName:=f.Path, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=10, _
                Top:=10)
                '↑いったんLeftとTopはいずれも10の位置にて挿入するけど
                'このLeft:=10には全く意味がない(あとで位置調整するので)
    
            '画像の縦横比は固定
            Shp.LockAspectRatio = msoTrue
            
            'JPEG画像のサイズを取得
            singleJpegWidth = Shp.Width
            singleJpegHeight = Shp.Height
            
            'JPEG画像の位置を調整
            Shp.Select
            ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True '指定されたオブジェクトを左右中央揃えにします。
            singleJpegLeft = Shp.Left
            Exit For
        End Select
    Next f
    
    Dim i As Long   'このiが重要な変数
    i = 0
    
    '③pngファイルはその下に別サイズ，位置（タイル状に）配列
    '次にPNGファイルを探す
    For Each f In oFolder.Files
   
        Select Case LCase(FSO.GetExtensionName(f.Path))
        Case "png"
        
            '画像を挿入
            Set Shp = ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
                FileName:=f.Path, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=0, _
                Top:=0)
                '↑いったんLeftとTopはいずれもゼロ位置にて挿入する
                'けど、この位置指定は全く意味がない(後で位置調整するので)
    
            '画像の縦横比は固定
            Shp.LockAspectRatio = msoTrue
    
            '1枚目の画像から、画像サイズ計算(フォルダ内PNG画像はすべて同じサイズとする)
            If i = 0 Then
'                iImageWidth = Fix((singleSlideWidth - iMarginTotal) / csingleClmCnt) 元ネタはスライドの幅を基準にしていたけど、今回質問者さんはJPEG画像の幅を基準にしたいようだったので変更
                iImageWidth = Fix((singleJpegWidth - iMarginTotal) / csingleClmCnt)
                Shp.Width = iImageWidth
                iImageHeight = Shp.Height
            End If
    
            '画像サイズ・位置の指定
            Shp.Width = iImageWidth
            Shp.Height = iImageHeight
'            Shp.Left = csingleMarginSlideEdge + Int(i Mod csingleClmCnt) * (iImageWidth + csingleMarginImage)元ネタはスライドの幅を基準にしていたけど、今回質問者さんはJPEG画像の左端を基準にしたいようだったので変更
            Shp.Left = singleJpegLeft + Int(i Mod csingleClmCnt) * (iImageWidth + csingleMarginImage)
'            Shp.Top = csingleMarginSlideEdge + Int(i / csingleClmCnt) * (iImageHeight + csingleMarginImage)元ネタはスライドの高さを基準にしていたけど、今回質問者さんはJPEG画像の後にPNGを並べたいので変更
            Shp.Top = csingleMarginSlideEdge + Int(i / csingleClmCnt) * (iImageHeight + csingleMarginImage) + singleJpegHeight
    
            '画像が多い場合、スライドの追加
            If ((i + 1) Mod csingleClmCnt) = 0 And (Shp.Top + Shp.Height + csingleMarginImage + iImageHeight) > singleSlideHeight Then
                ActivePresentation.Slides.Add( _
                    Index:=ActivePresentation.Slides.Count + 1, _
                    Layout:=ppLayoutBlank).Select
                i = 0
                'スライド追加時にDoEvents（定期的にWindowsへ（ユーザーへ）制御を戻すため）
                DoEvents
            Else
                '10回に1度DoEvents（定期的にWindowsへ（ユーザーへ）制御を戻すため）
                i = i + 1
                If i Mod 10 = 0 Then
                    DoEvents
                End If
            End If
        End Select
    Next f

    '終了処理
    Set f = Nothing
    Set oFolder = Nothing
    Set FSO = Nothing
    Set Shp = Nothing

End Sub

'フォルダ選択
Private Function SelectFolderInBrowser(Optional vRootFolder As Variant) As String
    Dim oFolder As Object
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder( _
                                 0, _
                                 "画像フォルダ選択", _
                                 &H211, _
                                 vRootFolder)
                'hwnd ダイアログ ボックスの親ウィンドウへのハンドル。 この値はゼロの場合があります。
                'H001 ファイル システム ディレクトリのみを返します。 ユーザーがファイル システムの一部ではないフォルダーを選択すると、[ OK] ボタンが灰色表示されます。
                'H010 ユーザーがアイテムの名前を入力できるようにする編集コントロールを参照ダイアログ ボックスに含めます。
                'H200  [参照] ダイアログ ボックスに [新しいフォルダー] ボタンを含めないでください。
    If Not (oFolder Is Nothing) Then
        SelectFolderInBrowser = oFolder.Items.Item.Path
    Else
        SelectFolderInBrowser = ""
    End If
    Set oFolder = Nothing
End Function