How to extract images out of the presentation

The routine below will extract all the images in a given presentation and copy then to the designated folder. The images will be exported at their original resolution. The routine copies an image shape onto another presentation and resizes the slide such that the pasted image fills the slide and then exports this slide as a picture format file. To obtain the original image from this export, the trick is to not to pass the optional Height and Width arguments while exporting the slide. PowerPoint will intelligently export the image at the original resolution.

In PowerPoint 2000 and later, there exists a hidden Export method associated with a shape which one can make use of directly. Here is an example which exploits that hidden method.

This routine while soon be included in Toolbox

' -------------------------------------------------------------------------
' Copyright ©1999-2007, Shyam Pillai, All Rights Reserved.
' -------------------------------------------------------------------------

' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' -------------------------------------------------------------------------

Sub ExtractImagesFromPres97()

On Error GoTo ErrorExtract

    Dim oPres As Presentation

    Dim oSldSource As Slide

    Dim oShpImg As ShapeRange

    Dim oShpSource As Shape

    Dim oSld As Slide

    Dim oShp As Shape

    Dim Ctr As Integer

    Dim sPath As String

    sPath = "D:\Temp\"

    Ctr = 0

    For Each oSldSource In ActivePresentation.Slides

        For Each oShpSource In oSldSource.Shapes

            If oShpSource.Type = msoPicture Then

                Set oShp = oShpSource

                Set oPres = Presentations.Add(False)

                With oPres.PageSetup

                    .SlideSize = ppSlideSizeCustom

                    .SlideHeight = oShp.Height

                    .SlideWidth = oShp.Width

                End With

                Set oSld = oPres.Slides.Add(1, ppLayoutBlank)

                oShp.Copy

                Set oShpImg = oSld.Shapes.Paste

		With oShpImg

			.Left = 0

			.Top = 0

		End With

                Ctr = Ctr + 1

                Call oSld.Export(sPath & "Img" & Format(Ctr, "00000") & ".JPG", "JPG")

                oPres.Close

            End If

        Next oShpSource

    Next oSldSource

    If Ctr = 0 Then

        MsgBox "There were no images found in this presentation", _

                        vbInformation, "Image extraction failed."

    End If

    Exit Sub

ErrorExtract:

    If Err.Number <> 0 Then

        MsgBox Err.Description, vbCritical, "Error #" & Err.Number

    End If

End Sub

' Work's only in PowerPoint 2000 and later
Sub ExtractImagesFromPres()
On Error GoTo ErrorExtract
    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim Ctr As Integer
    Dim sPath As String
    

    sPath = "C:\"

    Ctr = 0
    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
		' Hidden Export method 
                Call oShpSource.Export(sPath & "Img" & _ 
				Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
                Ctr = Ctr + 1
            End If
        Next oShpSource
    Next oSldSource
    If Ctr = 0 Then
        MsgBox "There were no images found in this presentation", _
                        vbInformation, "Image extraction failed."
    End If
    Exit Sub
ErrorExtract:
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, "Error #" & Err.Number
    End If
End Sub

Top