I wrote this in Word originally for a Work stream where file upload limit to a client database is only 4MB, it should be easy to code into Excel. Took me 8 months to write, as nothing online for this, and no code to directly code it - when you are desperate for a solution to compliment other timesaving macros, it seems, you can almost come up with any work around, just have to be brutal to just get it to work. Notes are mostly taken out of the code. First bit is in case QAT is pressed in error with no file open. SendKeys is entered twice to stop my USB numberpad from being toggled off or back on, if an odd number of images are compressed. No way to stop the Command bar from flickering. I have created test macros to detect if apply only to this picture is selected or not, so you can ensure the compression is not looped through every image. But I am not sensitive to strobing, and only compress up to 30 images at a time. If more it might cause an unnecessary delay, to loop through every image. You can add delay code between the first loop to call up the compression Command Bar, and the loop for remaining images, and at the end of the second loop, if strobing is a problem, I have a second QAT copy of this for Macro c, for 96ppi:
Sub MacroC_28_06_2022()
'150ppi SOURCE: [email protected]
Word.Application.ScreenUpdating = False
If Word.Application.Documents.Count = 0 Then
Exit Sub
End If
Dim oIlS As inlineshape
If Word.ActiveDocument.Inlineshapes.Count > 0 Then
Word.ActiveDocument.Inlineshapes(1).Select
VBA.SendKeys "%W{ENTER}", True
Application.Commandbars.ExecuteMso ("PicturesCompress")
DoEvents '''28/06/2022 Add SendKeys for a 2nd time each time used to undo toggling off the NumLock
VBA.SendKeys "%W{ENTER}", True
Application.Commandbars.ExecuteMso ("PicturesCompress")
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")
DoEvents '''2nd running to toggle numlock back on
VBA.SendKeys "%W{ENTER}", True
Application.Commandbars.ExecuteMso ("PicturesCompress")
End If
Next i
Word.Application.ScreenUpdating = True
End Sub
