1.需要导入到PPT的照片文件夹

2. Coding

Sub InsertPicture()
Dim oPPT As Presentation
Dim oSlide As Slide
Dim nSlide As Byte
Dim oCL As CustomLayout
Dim Shp As Shape
Dim myFile
Dim filearr()
Dim filearr0()
Dim myPath As String
Dim sPath As String
Dim FileName As String
Dim files As String
Dim x As String
Set oPPT = PowerPoint.ActivePresentation
'sPath = "C:\Users\Desktop\VBA\Outbound Loading Audit 10.31\"
    
With oPPT
nSlide = .Slides.Count
    With oSlide
    
       For j = 2 To nSlide
            Set oSlide = ActivePresentation.Slides(j)
            oSlide.Select  '选定当前ppt
            '以上为遍历每个PPT
'-------------------------------------------------------------------------------------------

                myPath = Dir("C:\Users\jishen\Desktop\VBA\Outbound Loading Audit 10.31\", vbDirectory)   'vbDirectory只看文件夹
                Do While myPath <> ""
                    ReDim Preserve filearr0(k)
                    filearr0(k) = Split(myPath & "")
                    k = k + 1
                    myPath = Dir
                    If myPath <> "." And myPath <> ".." And Trim(Mid(myPath, 1, 2)) = ActivePresentation.Slides(j).SlideNumber Then
                    
                        GoTo 100

                    End If

                Loop
              '以上为遍历每个文件夹，记得将文件夹名称前2位改成以数字开头，程序在此关联了ppt的页数
'----------------------------------------------------------------------------------------------
100
                                sPath = "C:\Users\Desktop\VBA\Outbound Loading Audit 10.31\" & myPath
                                myFile = Dir(sPath & "\*.jpg")
                                Do While myFile <> ""
                                    ReDim Preserve filearr(i)
                                    filearr(i) = Split(myFile, ".")(0)
                                    i = i + 1
                                    myFile = Dir
                                Loop
                                
                                
                                With oPPT
                                    For i = 0 To UBound(filearr) Step 6
                                        On Error Resume Next
                                        'Set oCL = .Slides(1).CustomLayout
                                        'nSlide = .Slides.Count
                                        If i Mod 6 = 0 And i <> 0 Then
                                            'Set oSlide = ActivePresentation
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i) & ".jpg", msoFalse, msoTrue, 301, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 1) & ".jpg", msoFalse, msoTrue, 518, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 2) & ".jpg", msoFalse, msoTrue, 735, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 3) & ".jpg", msoFalse, msoTrue, 301, 271, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 4) & ".jpg", msoFalse, msoTrue, 518, 271, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 5) & ".jpg", msoFalse, msoTrue, 735, 271, 216, 267)
                                            
                                            
                                        Else
                                            'Set oSlide = .Slides(nSlide)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i) & ".jpg", msoFalse, msoTrue, 301, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 1) & ".jpg", msoFalse, msoTrue, 518, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 2) & ".jpg", msoFalse, msoTrue, 735, 1, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 3) & ".jpg", msoFalse, msoTrue, 301, 271, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 4) & ".jpg", msoFalse, msoTrue, 518, 271, 216, 267)
                                            Set Shp = oSlide.Shapes.AddPicture(sPath & "\" & filearr(i + 5) & ".jpg", msoFalse, msoTrue, 735, 271, 216, 267)
                                        End If
                                        
                                    Next i
                                End With

                        
      Next j
   
    End With
End With

MsgBox "完成"
End Sub

3.完成后的样子