How can I (programmatically) step through all pictures and let the user choose compression?

Question

I have multiple slide decks with pictures that are too big (in pixels / resolution). I can use PowerPoint's "Compress Pictures" function to reduce the resolution, but there is not one single resolution that would suit all images (e.g. photos could go with 96 ppi E-mail resolution, while screenshots would require 220 ppi Print resolution). For that reason, I cannot simply apply one resolution to all pictures (by deselecting the "Apply only to this picture" checkbox).

So I would fancy a macro that steps through all pictures in the slide deck, and for each picture offers the user to select the resolution for compression (with a default set to 150 ppi Web, which suits most cases).

I was thinking of a code like this:

Sub Compress_Pictures_one_by_one()

Dim shp As Shape
Dim sld As Slide

'Loop through each slide in ActivePresentation:
For Each sld In ActivePresentation.Slides
    'Loop through each shape on the slide:
    For Each shp In sld.Shapes
     If shp.Type = msoPicture Then
        shp.Select
        'Show the Compress Pictures" dialog:
        Application.CommandBars.ExecuteMso "PicturesCompress"
        'Preselect Web resolution:
        SendKeys "%W", True
     End If
    Next shp
  Next sld
End Sub

However, this does not wait for the user to complete the dialog (with OK or Cancel) before moving on to the next picture.

Any idea how to solve? Or got any alternatives?

Answer 1

The code search for the dialog and wait for the dialog to be closed to continue

Declare PtrSafe Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal wClassName As Any, ByVal _
wWindowName As Any) As LongPtr
Sub Compress_Pictures_one_by_one()

Dim shp As Shape
Dim sld As Slide

'Loop through each slide in ActivePresentation:
For Each sld In ActivePresentation.Slides
    'Loop through each shape on the slide:
    For Each shp In sld.Shapes
     If shp.Type = msoPicture Then
        shp.Select
        'Show the Compress Pictures" dialog:

        Application.CommandBars.ExecuteMso "PicturesCompress"
        'Preselect Web resolution:
        SendKeys "%W", True
        While testDialogOpen
            DoEvents
        Wend
     End If
    Next shp
  Next sld
End Sub

Function testDialogOpen()
    Dim wHandle As LongPtr
    Dim wName As String

    wName = "Compress Pictures"
    wHandle = FindWindow(0&, wName)
    If wHandle = 0 Then
        testDialogOpen = False
    Else
        testDialogOpen = True
    End If
End Function