HelloWorld,
I have the feeling there is a way to compress image files with a vba script. If anyone agrees to that can we take up that challenge?
Basically, I will be compressing from a folder. And will like the smallest size possible.
Say below 100kb .
Thanks in advance
Kelly
I sorted image file size compression last summer, took me 8 months to write. I have to get files under 4MB for uploading to a client database all day.
I've added some code before the macro, so a MsgBox appears briefly at the end, I use this MsgBox active window text in a Log Macro in Excel, which records all active windows text.
I have a copy of this macro as macro c lowercase with the SendKeys as E for 96ppi.
Currently I'm trying to simplify the macro by detecting Compression options: "Apply only to this picture" and always ensure it is unticked. I couldn't work this out, so my loop of all images will either apply to that image selected, or all images. I want to save time and not loop through all of them. Stumped me still.
Private Declare PtrSafe Function CustomTimeOffMsgBox Lib "user32" Alias "MessageBoxTimeoutA" ( _
ByVal xHwnd As LongPtr, _
ByVal xText As String, _
ByVal xCaption As String, _
ByVal xMsgBoxStyle As VbMsgBoxStyle, _
ByVal xwlange As Long, _
ByVal xTimeOut As Long) _
As Long 'See SOURCE below
Sub MacroC_22_02_2023()
theState = Application.NumLock 'Mad, my external Trust USB Numberpad states False when
'hovering over Application.Numberlock via Fn+F8 and stepped past
'but says False when the numberpad is on!
'150ppi
Word.Application.ScreenUpdating = False 'doesn't work with SendKeys workarounds for no direct coding availability
'No explicit Source for creating this by
jam61mar@gmail.com,
james.martin@birmingham.gov.uk
'Macro "C" to compress images in Word if docx file size is too big
'Tip for adding [wait] after the sendkeys
SendKeys statement (VBA)
'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 speach marks
DoEvents '''28/06/2022 Add SendKeys for a 2nd time each time used to undo toggling off the NumLock
'''
VBA SendKeys (F2) and NumLock Issue
'150ppi - this is counter intuitive as it appears before the menu
VBA.SendKeys "%W{ENTER}", True
Application.CommandBars.ExecuteMso ("PicturesCompress")
'
Timer function (Visual Basic for Applications)
'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
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")
DoEvents '''2nd running to toggle numlock back on
VBA.SendKeys "%W{ENTER}", True
Application.CommandBars.ExecuteMso ("PicturesCompress")
'
Timer function (Visual Basic for Applications)
'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
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Finish = Timer
TotalTime = Finish - Start
Else
End
End If
Next i
'MsgBox appears briefly for 300 thousandths of a second, and Closes so Macro L detects the Macro C usage.
'SOURCE:
https://wwwextendoffice.com/documents/excel/3836-excel-message-box-timer-timeout.html
Call CustomTimeOffMsgBox(0, "", "WORD MACRO C - Compress Image(s) to 150ppi", vbInformation, 0, 300)
Word.Application.ScreenUpdating = True
End Sub
