Compressing all images in document to 150ppi

[James_Martin001]

Macro below took me 8 months to write. Out of necessity as have to compress client uploads to under 4MB frequently throughout the day. It works, but the PicturesCompress CommandBar flickers each time (this is doubled so SendKeys is always even and my USB numberpad is not toggled off or back on for odd numbered SendKeys). I am trying to change the state of the first tick (Apply only to this picture) to always be not ticked, so I don't need to loop through each image to simplify the macro. Any help to detect this tick state and remove would be appreciated.

Macro is copied from Grepper where I posted under the title "VBA compress all images in document to 150ppi"

Code: Select all

Sub MacroC_28_06_2022()
'Macro C compress all images in Document to 150ppi
'SOURCE: Grepper where I posted under the title "VBA compress all images in document to 150ppi"
'https://paypal.me/1ClickQAT?country.x=GB&locale.x=en_GB
Word.Application.ScreenUpdating = False 'doesnt stop CommandBars from flickering
         
'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
        'if can change status of CommandBar tick "Apply only to this picture" - loops not needed                       
                                VBA.SendKeys "%W{ENTER}", True 'save Macro c (lowercase) for 96ppi separate QAT & change %W for %E
                                'Opens the "Compress Pictures" Sub Menu on Picture Format
                                'A different version appear if the above Select 1st image line is switched off
                                Application.CommandBars.ExecuteMso ("PicturesCompress")
                               
                                DoEvents '28/06/2022 Repeat SendKeys to stop NumLock toggle off or on if odd number of images
                                'deletd source
                                VBA.SendKeys "%W{ENTER}", True
                                Application.CommandBars.ExecuteMso ("PicturesCompress")
                               
                                'deleted source
                                Dim PauseTime, Start, Finish, TotalTime
                                PauseTime = 0 'Add a delay if the CommandBars flicker is a problem
                                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 'save Macro c (lowercase) for 96ppi separate QAT & change %W for %E
                                Application.CommandBars.ExecuteMso ("PicturesCompress")
                               
                                DoEvents
                                VBA.SendKeys "%W{ENTER}", True
                                Application.CommandBars.ExecuteMso ("PicturesCompress")
                               
                                'Dim PauseTime, Start, Finish, TotalTime
                                PauseTime = 0 'Add a delay if the CommandBars flicker is a problem
                                Start = Timer
                                Do While Timer < Start + PauseTime
                                DoEvents
                                Loop
                                Finish = Timer
                                TotalTime = Finish - Start
                                Else
                                End
                   
                    End If
                Next i
 
Word.Application.ScreenUpdating = True
End Sub

[HansV]

Welcome to Eileen's Lounge! I'll try to take a look later today.

[HansV]

Hmm, this is beyond me. Paul (macropod)?

[James_Martin001]

I use a Slickstick, Outlook macro to save current email in list view, which saves the email to docx. A minor clarification to the original post. I am consolidating as many client image files into one docx rather than the default action to upload every individual image file, which just creates more auditing work in the future.

I have a Slipstick macro to also import all attachments to a secondary c drive folder, which the files from the previous client are killed/deleted; and a macro in Word to import the image attachments to the cursor point.

So the compression macro saves time collectively with 3 macros in Outlook, including a txt save of an email, and 10 image manipulation macros in Word. I have the Greg Maxey Page/Section break macro (I have added deleting the header and footer from the previous Section); and Greg wrote for me an image rotation userform, to rotate all/Selection of images by 90°, 180° or 270°.

I have questioned on ChatGPT "How to VBA code change commandbar tick status to off?" And it provided a suggestion, but I haven't got it to work yet, some ideas though. I have not been taught VBA, so weak on the coding rules, but strong on creativity and persistently trying solutions. I am a brute force coder. And wherever possible, only 1 click execution from QAT. The Rotation macro with a userform is the only one that needs 2 or 3 clicks.

The annoying thing about the tick status is that it remembers the state of last use, or the state at Word App start. When writing macro C, I knew I had to loop through all images no matter what this status is. The flickering is not good for epilepsy. Also if you need to compress more than the 20-30 images I do, then the time delay becomes significant.

[ChrisGreaves]

...Out of necessity as have to compress client uploads to under 4MB ...

I looked at a similar problem twenty years ago in compiling from MSWord documents into HTML, and then uploading HTML pages with embedded images.
Right now I embed images in an MSWord document using the {IncludePicture} field code. My images are around 4MB each, but I do not need that quality for my web pages.

... macro in Word to import the image attachments

So I have a macro "LoadImages" which works out which images are more recent than the latest image in the document, inserts the the {IncludePicture} field codes into the document, AND copies the 4MB images to a RAM drive.
I apply VSO Image Resizer 4 to the images in the RAM drive to drop them from 4MB to about 250KB, and cut-and-paste those images back into the document's folder.

This procedure works for one to more than twenty images at a time.
If you are interested I can supply more details.

Cheers, Chris

[SpeakEasy]

An alternative might be to create a Word template which has the default image resolution* set to 150dpi, and base your working document off that template Load in the images,. then simply save the document. This should force all the images to be a maximum of 150dpi without any flickering or VBA looping

* File -> Options -> Advanced - Image Size and Quality -> Default Resolution