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

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?

CodePudding user response：

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

CodePudding user response：

In my final code, I have added some user information as well as the option for the user to verify the compression result and then choose to move on or to apply a different compression setting. Wanted to share in case anyone needs it:

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
    Dim intCounter As Integer
    Dim blnNext As Boolean
    
    'Intro:
    If MsgBox("This procedure will loop through all pictures in you slide deck. " _
        & "For each picture it will offer you to select a compression. " _
        & "If you do not want to change the compression of a picture, hit the Cancel button in the Compress Pictures dialog. " & vbCr _
        & "After each compression setting you'll be asked whether to keep the compression setting and move on to the next picture, " _
        & "or to re-choose a compression for the current picture, or to stop processing. ", _
        vbInformation   vbOKCancel, "Introduction") = vbCancel Then Exit Sub
    
    intCounter = 0
    
    '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
            intCounter = intCounter   1
            ActiveWindow.View.GotoSlide sld.SlideIndex
            shp.Select
            'MsgBox "Picture format: " & shp.PictureFormat
            Do
                'Show the Compress Pictures" dialog:
                Application.CommandBars.ExecuteMso "PicturesCompress"
                'Preselect Web resolution:
                SendKeys "%W", True
                While testDialogOpen
                    DoEvents
                Wend
                'Have user verify the compression result and choose how to proceed:
                Select Case MsgBox("Move to the next picture?" & vbCr _
                        & "Yes: Continue with next picture." & vbCr _
                        & "No: Re-choose a setting for the current picture." & vbCr _
                        & "Cancel: Stop processing any further pictures.", _
                        vbYesNoCancel   vbQuestion, _
                        "Continue?")
                    Case vbYes
                        blnNext = True
                    Case vbNo
                        blnNext = False
                    Case vbCancel
                        If MsgBox("You are about to cancel the task. " & vbCr _
                            & intCounter & " picture" & IIf(intCounter = 1, " has", "s have") & "  been touched." & vbCr _
                            & "No further pictures will be processed." & vbCr _
                            & "Are you sure you want to stop?", _
                            vbCritical   vbYesNo, "Cancel?") _
                            = vbYes Then Exit Sub
                End Select
            Loop Until blnNext
         End If
        Next shp
    Next sld
    
    'Finish:
    If intCounter = 0 Then
        MsgBox "No pictures have been detected in your slides.", vbInformation   vbOKOnly
    Else
        MsgBox "Task completed. " & vbCr & intCounter & " picture" & IIf(intCounter = 1, " has", "s have") & " been touched.", vbInformation, "Compress Pictures"
    End If
    
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

Thanks again for your help, wrbp!