Блог

Мне нужна помощь, чтобы сжать все изображения в книге Excel через VB (формат электронной почты 96 ppi).

Я пробовал sendkeys, но, похоже, это не работает.

 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
  

Возможно, вам поможет следующее «решение»

 Sub test()

    Dim wsh As Worksheet

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

    SendKeys "%e", True
    SendKeys "~", True
    Application.CommandBars.ExecuteMso "PicturesCompress"
End Sub
  

Но если вы не выберете ни одного изображения, при вызове вы получите следующее диалоговое окно Application.CommandBars.ExecuteMso "PicturesCompress" . Если вы выберете Web / Screen, вы получите разрешение 96 точек на дюйм.

Я нашел это решение, и оно работает для меня. Спасибо, 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
  

Если вы отключите 2-ю строку в if блоке, вы получите другое подменю сжатия, изображенное ранее, при активной второй строке вы получите фактическое подменю «Сжимать изображения» в Word, я только вчера разобрал это, месяцами безуспешно пытался автоматизировать только отправку ключей, так что, надеюсь, это более стабильный способ сборки с 150ppi изначально, проблема может заключаться в том, что параметры сжатия должны быть сброшены на false, поскольку предыдущие выборы запоминаются. Также необходимо закодировать активное сохранение документа. Я предпочитаю макросы с одним щелчком мыши в QAT. Должно быть просто использовать этот код в Excel с небольшими изменениями, если это необходимо.

 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:jam61mar@gmail.com

'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://learn.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://learn.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://learn.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