Sounds like you have the new loop inside the previous loop. Post you completed code and I'll have a look.

__________________
Microsoft PowerPoint MVP 2007-2023
Free Advanced PowerPoint Tips and Tutorials

See if this works:


Sub ImportABunch()
' based on code from pptfaq

Dim SW As Long
Dim SH As Long
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim iCount As Integer
'++++++++++++++++++++++++++++++NEW
If ActivePresentation.Slides.Count > 1 Then _
ActivePresentation.Slides(2).Shapes.Range.Copy
'++++++++++++++++++++++++++++++NEW
' Edit these to suit:
strPath = "c:\Users\John\Desktop\Pics\"
strFileSpec = "*.png"
SH = ActivePresentation.PageSetup.SlideHeight
SW = ActivePresentation.PageSetup.SlideWidth
strTemp = Dir(strPath & strFileSpec)

Do While strTemp <> ""
Set oSld = ActivePresentation.Slides.Add _
(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
iCount = iCount + 1
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=msoTrue, _
Height:=msoTrue)

'reset height to a 150points less than slide height
With oPic
.LockAspectRatio = msoTrue
.Height = SH - 150
.Left = (SW - oPic.Width) / 2
.Top = 100
End With
' Get the next file that meets the spec and go round again

'=========================NEW
oSld.Shapes.Paste
'=========================NEW
strTemp = Dir
Loop
If MsgBox("I added " & iCount & " Images." & vbCrLf & "Would you like to delete the files? This cannot be reversed.", vbYesNo) = vbYes Then
Kill strPath & "*png"""
End If
End Sub

__________________
Microsoft PowerPoint MVP 2007-2023
Free Advanced PowerPoint Tips and Tutorials

This is fabulous! Thanks so much!

But the new slides still come in at the end, but after the current/selected slide.

DJ

I didn't understand what you meant!

Try

Sub ImportABunch()
' based on code from pptfaq

Dim SW As Long
Dim SH As Long
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim iCount As Integer
Dim lngStart As Long
On Error GoTo err
'++++++++++++++++++++++++++++++NEW
If ActivePresentation.Slides.Count > 1 Then _
ActivePresentation.Slides(2).Shapes.Range.Copy
'++++++++++++++++++++++++++++++NEW
' Edit these to suit:
strPath = "c:\Users\John\Desktop\Pics\"
strFileSpec = "*.png"
SH = ActivePresentation.PageSetup.SlideHeight
SW = ActivePresentation.PageSetup.SlideWidth
strTemp = Dir(strPath & strFileSpec)
lngStart = ActiveWindow.Selection.SlideRange(1).SlideIndex
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides.Add _
(lngStart + 1, ppLayoutBlank)
lngStart = lngStart + 1
iCount = iCount + 1
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=msoTrue, _
Height:=msoTrue)

'reset height to a 150points less than slide height
With oPic
.LockAspectRatio = msoTrue
.Height = SH - 150
.Left = (SW - oPic.Width) / 2
.Top = 100
End With
' Get the next file that meets the spec and go round again

'=========================NEW
oSld.Shapes.Paste
'=========================NEW
strTemp = Dir
Loop
If MsgBox("I added " & iCount & " Images." & vbCrLf & "Would you like to delete the files? This cannot be reversed.", vbYesNo) = vbYes Then
Kill strPath & "*png"""
End If
Exit Sub
err:
MsgBox "There's an error"
End Sub

__________________
Microsoft PowerPoint MVP 2007-2023
Free Advanced PowerPoint Tips and Tutorials

You did it! Words can not express!

I recorded a macro to add a transition too all of the slides, but the recorded doesn't capture Select All. How do I make these commands apply a transition to all slides, please?

DJ

Your code would workonly if all slides were already selected. To apply to all the slides in a presentation use:

' Add Transition
With ActivePresentation.Slides.Range.SlideShowTransitio n ' watch out for the auto added extra space!
.EntryEffect = ppEffectFadeSmoothly
.Speed = ppTransitionSpeedFast
.AdvanceOnClick = msoTrue
End With

__________________
Microsoft PowerPoint MVP 2007-2023
Free Advanced PowerPoint Tips and Tutorials

It's perfect! Now I can get to work!

Thanks a bunch, John! I'm sending you a virtual Pepsi or beer or something! :-)

DJ

Not Pepsi thank you!

If you are based in the UK, Seattle area, New Orleans or Vancouver then you might get a chance to buy a real beer!

__________________
Microsoft PowerPoint MVP 2007-2023
Free Advanced PowerPoint Tips and Tutorials