Insert image and change size

Question

I want to paste images from a directory into PowerPoint then resize them.

I have 16 images all in one directory which need updating each month. The task is:

1. Open directory
2. Open first image
3. Paste image into PowerPoint
4. Reposition image to top left
5. Resize image to height 550 by width 960 (fills A4 page)
6. Send image to back
7. Move to next slide
8. Repeat for second image
9. Continue until no more images in directory

Directory is (e.g.) "C:\Users\xxxxxx\Documents\Work\Procurement Project\Slides"

First image name is (e.g.) "01 Summary", second is "02 Client Contracts" etc.

I think I need a str and a path and a table for the str to add to path to create each new path using i and i + 1 etc.

I think need code like this:

Sub Picture_size_and_position()

Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection

ActiveWindow.View.GotoSlide oSlide.SlideIndex

With ActiveWindow.Selection.ShapeRange
    .LockAspectRatio = msoFalse
    .Height = 550
    .Width = 960
    .Left = 0
    .Top = 0
End With

End Sub

Then I'm sure I need a loop to repeat this until there's nothing left in the directory using some combination of i and j.

Answer 1

Have an idea to automate it/or upon manual launch of a new Macro Enabled PowerPoint Template file. To automate macro upon file open, add customUI: onLoad="ImagesToPowerPoint". Search "CustomUI Editor" for it.

Note I have not fully tested the automation part.

Option Explicit

Sub ImagesToPowerPoint()
    Const FileType As String = "*.png"
    Dim sSaveFilePath As String, sSaveFileName As String, sImagesFolder As String
    Dim oLayout As CustomLayout, oSlide As Slide, i As Long, sFile As String

    sImagesFolder = Environ("USERPROFILE") & "\Documents\Work\Procurement Project\Slides\"
    ' Prepare auto save PowerPoint file name
    sSaveFilePath = Environ("USERPROFILE") & "\Documents\Work\PowerPoints\"
    sSaveFileName = Format(Now, "yyyy_mmdd") & "_Procurement.pptx"

    With ActivePresentation
        ' Use the first layout for all new slides
        Set oLayout = .SlideMaster.CustomLayouts(1)
        ' Start processing all files in the folder
        sFile = Dir(sImagesFolder & FileType)
        Do Until sFile = ""
            ' Add new slide
            Set oSlide = .Slides.AddSlide(.Slides.Count, oLayout)
            ' Delete all the shapes from that layout
            For i = oSlide.Shapes.Count To 1 Step -1
                oSlide.Shapes(i).Delete
            Next
            ' Add the image to slide
            With oSlide.Shapes.AddPicture(sImagesFolder & sFile, msoFalse, msoTrue, 0, 0, oLayout.Width, oLayout.Height)
                .LockAspectRatio = msoFalse
                .AlternativeText = Now & " | " & sImagesFolder & sFile
            End With
            sFile = Dir
        Loop
        .SaveAs sSaveFilePath & sSaveFileName
    End With
    Presentations(sSaveFileName).Close
    If Presentations.Count = 0 Then Application.Quit
End Sub

Answer 2

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:\Users\username\"
strFileSpec = "*.png"

strTemp = Dir(strPath & strFileSpec)

i = 1

Do While strTemp <> ""
    Set oSld = ActivePresentation.Slides(i)
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=960, _
    Height:=550)

    i = i + 1


    With oPic
        .LockAspectRatio = msoFalse
        .ZOrder msoSendToBack
    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

Credit to http://www.pptfaq.com/index.html - Great little site!