1.需要导入到PPT的照片文件夹
- 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.完成后的样子