Can a Powerpoint VBA script identify the size of image elements on each slide?

Question

I have a PPT which is over the size limit to send via email. I've compressed the images on every slide. I want to understand which slides are bloating the file.

Is there a way of creating a VBA routine that can do a foreach and identify the size of each image or object on each page helping me track down culprits and making trade-offs of which slides to keep/simplify/drop?

Answer 1

There appears to be an Add-in which PPTFAQ links to, which will identify the sources of bloat, although it does not work for PPT 2007+ file formats (PPTM/PPTX, etc.), and it may not work for PPT versions 2007+

http://billdilworth.mvps.org/SizeMe.htm

In any case, it can be done, by someone who knows a lot about PowerPoint.

The PPTFAQ site has a lot of other potentially helpful information about what can contribute to your file bloat. For instance about WMFs, slide master templates, raster images, etc.

PowerPoint has some default settings that will work against you when you're trying to keep file size down...

an embedded or linked object's WMF includes any bitmap data, your PPT file bloats.> [Windows Metafiles] can include bitmap images, but only as uncompressed BMPs...

When you enable Review, PowerPoint stores a copy of the original presentation as a hidden OLE object - this is the baseline for comparisons with the presentation itself as it's edited later.

etc.

Updated

This will NOT work for PPT 2011 / Mac version of PowerPoint. I played around a bit with Ron DeBruin's functions and put this one together pretty quickly, I am not sure how useful it will be for OP but perhaps will be valuable to someone else in the future.

Optional HTMLExtract allows you to convert from the ZIP or HTML. I initially did the HTML because it seemed easier, but then figured out how to do the ZIP version so I include both options.

Option Explicit
Sub GetMediaSizes()
    Dim DefPath As String
    'Destination folder
    DefPath = "C:\Users\" & Environ("username") & "\desktop\PPT_Report\"    '<<< Change path as needed
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
    
    ExtractPPTFile DefPath
    InspectFiles DefPath

    'Use Shell to open the destination folder
    Shell "C:\WINDOWS\explorer.exe """ & DefPath, vbNormalFocus

End Sub

Sub InspectFiles(fPath As String, Optional HTMLExtract As Boolean = False)
    Dim FSO As Object           'Scripting.FileSystemObject
    Dim fldr As Object          'Scripting.Folder
    Dim fl As Object            'Scripting.File
    Dim i As Long               'counter variable
    Dim txtFile As Object       'text file
    Dim fileInfo() As Variant   'An array to hold file informations
    Dim txtFilePath As String   'path for storing the log/report
    Dim extractPath As String   'path for the exported HTML components
    
    txtFilePath = fPath & "Report.txt"
    extractPath = fPath & IIf(HTMLExtract, "Extract_Files", "ppt\media") '"Extract_Files" for the HTML
    
    Set FSO = CreateObject("scripting.filesystemobject")
    Set fldr = FSO.GetFolder(extractPath)
    ReDim fileInfo(fldr.Files.Count)
    For Each fl In fldr.Files
        Select Case UCase(Right(fl.Name, 3))
            Case "GIF", "BMP", "PNG", "JPG" ' inspect only image files, modify as needed
                fileInfo(i) = fl.Name & vbTab & fl.Size
                i = i + 1
            Case Else
            ' Do nothing
        End Select
    Next
    Set txtFile = FSO.CreateTextFile(txtFilePath, True, True)
    txtFile.Write Join(fileInfo, vbNewLine)
    txtFile.Close
    
    Set txtFile = Nothing
    Set fldr = Nothing
    Set fl = Nothing
    Set FSO = Nothing

End Sub


Sub ExtractPPTFile(fPath As String, Optional HTMLExtract As Boolean = False)
    'Based on
    'http://www.rondebruin.nl/win/s7/win002.htm

    Dim FSO As Object
    Dim pres As Presentation
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim fDialog As FileDialog
    Dim oApp As Object
    Dim ext As String
    Dim tempName As String
    
    Set fDialog = Application.FileDialog(msoFileDialogOpen)
    fDialog.AllowMultiSelect = False
    fDialog.Show
    

    If fDialog.SelectedItems.Count = (0) Then
        'Do nothing
    Else
        Fname = fDialog.SelectedItems(1)
        FileNameFolder = fPath
        Set FSO = CreateObject("scripting.filesystemobject")
        If Not FSO.FolderExists(fPath) Then
            FSO.CreateFolder fPath
        End If
        'Comment these lines if you do NOT want to delete all the files in the folder DefPath first if you want
        On Error Resume Next
        Kill fPath & "*.*"
        On Error GoTo 0

        If HTMLExtract Then
            fDialog.Execute
            'Extract the files into the Destination folder
            Set pres = Presentations.Open(Fname)
            ActivePresentation.SaveAs fPath & "Extract.htm", ppSaveAsHTML, msoFalse
            ActivePresentation.Close
            Presentations(Fname).Close
        Else:

        ext = Mid(Fname, InStrRev(Fname, "."))
        tempName = Replace(Fname, ext, ".zip")
        Name Fname As tempName
        Set oApp = CreateObject("Shell.Application")
            oApp.Namespace(CVar(fPath)).CopyHere oApp.Namespace(CVar(tempName)).items
            On Error Resume Next
            FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
        End If
        Name tempName As Fname
    End If
End Sub