Batch Insert a folder full of pictures, one per slide

This is intended as sample code for quick one-time uses or as an example that'll help you get started writing your own macros. If you're looking for a reliable production tool for batch importing images into slides, please see BATCH IMPORT images into PowerPoint

Note: This code only works in Windows versions of PowerPoint, not Mac.

Sub ImportABunch()

Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

' Edit these to suit:
strPath = "c:\My Pictures\"
strFileSpec = "*.jpg"

strTemp = Dir(strPath & strFileSpec)

Do While strTemp <> ""
    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)
    ' width/height of -1 tells PPT to import the image at its "natural" size

' Optionally, make it fill the slide - even if that means changing the proportions of the picture
' To do that, uncomment the following:
'  With oPic
'      .LockAspectRatio = msoFalse
'      .height = ActivePresentation.PageSetup.Slideheight
'      .width = ActivePresentation.PageSetup. Slidewidth
'  End With

' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
' without changing the proportions
' Leave the above commented out, uncomment this instead:
'   With oPic
'     If 3 * .width > 4 * .height Then
'         .width = ActivePresentation.PageSetup.Slidewidth
'         .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
'     Else
'       .height = ActivePresentation.PageSetup.Slideheight
'         .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
'     End If
'   End With

' Optionally, add the full path of the picture to the image as a tag:
'With oPic
'  .Tags.Add "OriginalPath", strPath & strTemp
'End With

    ' Get the next file that meets the spec and go round again
    strTemp = Dir
Loop

End Sub

Another approach for multiple pictures on a slide

Sub ImportABunch()

Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

Dim lCurrentRound As Long
lCurrentRound = 1

' Edit these to suit:
'strPath = "C:\Users\dklaz\Desktop\Prep for China\Factory Pictures\Best Beteck\"
strPath = "P:\photos\MakePrints_2008_Japan\"
strFileSpec = "*.jpg"

strTemp = Dir(strPath & strFileSpec)

Do While strTemp <> ""

    If lCurrentRound = 1 Then   ' add a new slide
        Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)
    End If
            Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, _
            Top:=0, _
            Width:=-1, _
            Height:=-1)

        ' Edit the Left/Top values below if you want to place
        ' the images in specific locations
'        Select Case lCurrentRound
'            Case 1
'                oPic.Left = 0
'                oPic.Top = 0
'
'            Case 2
'                oPic.Left = 100
'                oPic.Top = 100
'
'            Case 3
'                oPic.Left = 200
'                oPic.Top = 200
'
'            Case 4
'                oPic.Left = 300
'                oPic.Top = 300
'        End Select

        '' Or try something like this to assign each
        '' image's top/left to a quadrant
        Select Case lCurrentRound
            Case 1
                oPic.Left = 0
                oPic.Top = 0

            Case 2
                oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
                oPic.Top = 0

            Case 3
                oPic.Left = 0
                oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2

            Case 4
                oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
                oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2
        End Select

    If lCurrentRound = 4 Then
        lCurrentRound = 1
    Else
        lCurrentRound = lCurrentRound + 1
    End If

    strTemp = Dir

Loop

End Sub

See How do I use VBA code in PowerPoint? to learn how to use this example code.

Search terms:

---