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:

Open directory
Open first image
Paste image into PowerPoint
Reposition image to top left
Resize image to height 550 by width 960 (fills A4 page)
Send image to back
Move to next slide
Repeat for second image
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.

Thanks for the credit! You might instead want to link rather than insert the images when setting up the presentation. Then all you'd need to do is edit the images, or save the new ones atop the originals with the same file name. PPT will update automatically when you open the presentation the next time. Or choose Link and Insert; that way the links won't break so easily. — Steve Rindsberg
– Steve Rindsberg, Commented Oct 5, 2023 at 18:12

exoticdisease · Accepted Answer · 2018-08-14 11:06:07Z

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!

PatricK · Accepted Answer · 2018-10-30 05:34:49Z

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

Collectives™ on Stack Overflow

Insert image and change size

2 Answers 2

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related