Compress all images in Excel workbook via VBA

Question

I need help to compress all images in Excel workbook via VB (email format 96 ppi).

I tried sendkeys but seems it doesn't work.

Sub test()

  Dim wsh As Worksheet

  Set wsh = Worksheets("Sheet1")
  wsh.Activate
  wsh.Shapes(1).Select

  SendKeys "%JP", True
  SendKeys "%M", True
  SendKeys "%e", True
  SendKeys "~", True

End Sub

Answer 1

I found this solution and it works for me. Thanks, Storax

Sub test()

Dim wsh As Worksheet

    Set wsh = Worksheets("Sheet1")
    wsh.Activate
    wsh.Shapes(1).Select

    SendKeys "%w", True
    SendKeys "~", True
    Application.CommandBars.ExecuteMso "PicturesCompress"

End Sub

Answer 2

If you switch off the 2nd line in the if block, you get the different compress sub menu pictured previously, with the second line active it you get the actual "Compress Pictures" sub menu in Word, I only just sorted this yesterday, been struggling for months to automate with just send keys with no success, so hopefully this is a more stable way to build with 150ppi initially, problem may be that Compression Options need to be reset to false, as previous selections are remembered. Also need to code an active document save. I prefer single click macros on QAT. Should be simple to use this code in Excel with slight changes if needed.

Finished my version for Word. To change all images in a word file - I have one QAT link for 150ppi and another for 96ppi need them for work. I had to add a delay in the loop to stop flicker of the commandbar, as some people may be sensitive to this . Not an ideal solution. I have the delay set to zero on my computer. I would prefer to reset the Pictures Compress menu and not need to loop through all the images.

Sub CompressI_13_05_2022()

'SOURCE:Can't remember where I found the ExecuteMSO vba code
'SOURCE:[email protected]

'Macro to compress images in Word if docx file size is too big
'If there are images in the file (so will do nothing if pressed in error)
    If word.activedocument.Inlineshapes.Count > 0 Then
        'Select the first image so that the "Picture Format" Ribbon Menu appears
        word.activedocument.Inlineshapes(1).Select
        'Opens the "Compress Pictures" Sub Menu on Picture Format
        'A different version appears if the above Select 1st image is switched off, so that line is critical
        Application.CommandBars.ExecuteMso "PicturesCompress"
    'Send Keys not done yet... to select different compression, for me 150ppi and 96ppi are needed
    'For two single click QAT links 
    End If
End Sub

Sub MacroIC_25_05_2022()

'150ppi
Application.screenupdating = False 'lowercase and does not seem to work as CommandBar flickers and is visible
'Need to cross reference with private laptop - possible problem with Work Laptop Visual Basic References

'No explicit Source for creating this by
'Macro "C" to compress images in Word if docx file size is too big
'Tip for adding [wait] after the sendkeys https://docs.microsoft.com/en-us/office/vba/Language/Reference/user-interface-help/sendkeys-statement
            
'If Macro C is pressed in error with no file in Open Word App
If word.Application.Documents.Count = 0 Then
    Exit Sub
End If
   
Dim oIlS As inlineshape

If word.activedocument.Inlineshapes.Count > 0 Then
        
        'Select the first image so that the "Picture Format" Ribbon Menu appears
        word.activedocument.Inlineshapes(1).Select
                                          
                                '150ppi - this is counter intuitive as it appears before the menu
                                VBA.SendKeys "%W{ENTER}", True
            
                                'Opens the "Compress Pictures" Sub Menu on Picture Format
                                'A different version appears if the above Select 1st image line is switched off, so that line is critical for the actual sub menu
                                Application.Commandbars.ExecuteMso ("PicturesCompress") '20-05-2022 Can add brackets around the speech marks
                                          
                                'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/timer-function
                                'for a delay to stop the Commandbar sub menu from flickering too much, still prefer to not see it
                                Dim PauseTime, Start, Finish, TotalTime
                                PauseTime = 0.25
                                Start = Timer
                                Do While Timer < Start + PauseTime
                                DoEvents
                                Loop
                                Finish = Timer
                                TotalTime = Finish - Start
                                Else
                                End
                                          
End If
        
'Restarting a loop for the rest of the images in the Active Document
                            
                For i = 2 To word.activedocument.Inlineshapes.Count
                
                    If word.activedocument.Inlineshapes.Count > 1 Then
                        word.activedocument.Inlineshapes(i).Select
                                            
                                VBA.SendKeys "%W{ENTER}", True
                  
                                Application.Commandbars.ExecuteMso ("PicturesCompress")
                                
                                'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/timer-function
                                'for a delay to stop the Commandbar sub menu from flickering too much, still prefer to not see it
                                'Dim PauseTime, Start, Finish, TotalTime
                                PauseTime = 0.25
                                Start = Timer
                                Do While Timer < Start + PauseTime
                                DoEvents
                                Loop
                                Finish = Timer
                                TotalTime = Finish - Start
                                Else
                                End
                                                                                
                    End If
            
                Next i

Application.screenupdating = True

End Sub