Code to delete unused cropped region

[OpPot]

Hi there,

My goal is to delete the cropped space of images that is currently unused. That is, after an image has been cropped, I want to use "compress picture" function in excel/word/powerpoint to batch process this over multiple files. My problem is that I can do this just fine in excel, however, I come across several problems when I try to do the same in say - powerpoint or word as the syntax is different.

The goal of my code is simply to create a macro that opens a file, selects a shape, uses compress picture (which is to apply to all shapes/pictures in the document), save changes and close the page. This seems simple enough, but I admit I'm rusty with my VBA. The end goal of this is to use another piece of software to replace these these correctly cropped images. This is because the software counts the uncropped space as part of the dimensions for the image replacement and my attempts at adjusting for this have been in vain. Once the images have been correctly cropped, the image replacement software allows me to just replace the images in bulk with one of my choosing. The software is called Office Find and Replace.

The end goal is just to rebrand a batch of documents and the above software lets me replace specific logos with another logo.

Sub CompressAllImages(wb As Workbook)
Dim wsh As Worksheet
Dim shp As Shape[CODE=vba]

Dim count As Long
'Set wb = Application.ThisWorkbook
'Look through all the sheets and for each image found, delete the uncropped space.
Application.ScreenUpdating = False
For Each wsh In wb.Worksheets
For Each shp In wsh.Shapes
shp.Select
'count = count + 1
'Send ALT + A Command to Picture Compress window
SendKeys "%a", True
'Send Enter Key to Picture Compress window
SendKeys "~", True
Application.CommandBars.ExecuteMso "PicturesCompress"
Next shp
Next wsh
'MsgBox "Total Shapes in Worksheet " & count
Application.ScreenUpdating = True
End Sub
[/CODE]

Batch process code:

Sub OpenMultipleWorkbooksInFolder()
    Dim wb As Workbook
    Dim fileDialog As fileDialog
    Dim folderName As String
    Dim fileName As String
    Dim currentWin As Window
    
    Set currentWin = ActiveWindow
       
    Set fileDialog = Application.fileDialog(msoFileDialogFolderPicker)
    
    If fileDialog.Show = -1 Then
        folderName = fileDialog.SelectedItems(1) & Application.PathSeparator
        fileName = Dir(folderName & "*.xls*")
        Application.ScreenUpdating = False
        Do While fileName <> ""
            Set wb = Workbooks.Open(folderName & fileName)
            currentWin.Activate
            wb.Windows(1).Visible = False
            Call CompressAllImages(wb)
            wb.Windows(1).Visible = True
            wb.Close SaveChanges:=True
            fileName = Dir
        Loop
            Application.ScreenUpdating = True
    End If
End Sub

This is the code I've used for excel and it works just fine although, I could probably skip looking through EVERY by just using the compress picture function once on each shape in each document. The problem is, I truthfully have attempted to write similar code in powerpoint or word, but the my code seems to fail at the

 Application.CommandBars.ExecuteMso "PicturesCompress

" line.

Example code:

Sub CompressAllImages(pp As Presentation)
    'Dim pp As Presentation
    Dim slide As slide
    Dim shp As Shape
    'Set pp = ActivePresentation
    For Each slide In pp.Slides
        For Each shp In slide.Shapes
            If shp.Type = msoPicture Then
                shp.Select
                'Send ALT + A Command to Picture Compress window
                SendKeys "%a", True
                'Send Enter Key to Picture Compress window
                SendKeys "~", True
                Application.CommandBars.ExecuteMso "PicturesCompress"
                End If
          Next shp
    Next slide
End Sub

 

[OpPot]

As I see no way to edit,

Here is the code properly formatted:

VBA Code:
Sub CompressAllImages(wb As Workbook)
Dim wsh As Worksheet
Dim shp As Shape
Dim count As Long
'Set wb = Application.ThisWorkbook
'Look through all the sheets and for each image found, delete the uncropped space.
Application.ScreenUpdating = False
For Each wsh In wb.Worksheets
For Each shp In wsh.Shapes
shp.Select
'count = count + 1
'Send ALT + A Command to Picture Compress window
SendKeys "%a", True
'Send Enter Key to Picture Compress window
SendKeys "~", True
Application.CommandBars.ExecuteMso "PicturesCompress"
Next shp
Next wsh
'MsgBox "Total Shapes in Worksheet " & count
Application.ScreenUpdating = True
End Sub