Photo size problem

[HansV]

The version below loops through all worksheets, but when I run it in Excel 2013, I get a dialog for each worksheet.

Code: Select all

Sub CommandButton1_Click()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim f As Boolean

    Application.ScreenUpdating = False

    For Each wsh In Worksheets
        wsh.Select
        f = False
        For Each shp In wsh.Shapes
            Select Case shp.Type
                Case msoLinkedPicture, msoPicture
                    shp.Select Replace:=Not f
                    f = True
            End Select
        Next shp

        With Selection
            Application.EnableCancelKey = xlDisabled
            Application.SendKeys "aw{ENTER}{ESC}{ESC}", False
            Application.SendKeys "%(oe)~{TAB}~"
            Application.CommandBars.ExecuteMso "PicturesCompress"
            DoEvents
            Application.EnableCancelKey = xlInterrupt
        End With
        wsh.Range("A1").Select
    Next wsh

    Application.ScreenUpdating = True
End Sub

S0019.png

[ABabeNChrist]

I used a workbook with 3 sheets and added 2 pictures on each sheet (each picture was about 2.5 MB before inserted). After pictures were inserted and workbook saved, the workbook size was 3.1 MB. I then ran the code and experienced the same thing; I had to select “apply to selected pictures only” for each sheet. Once completed I again saved the workbook and the new workbook size has been reduced to 273KB. So it seems to work, but have to click through every sheet. Some of my workbooks have 25+ sheets. I’m guessing this will also affect hidden sheets.

[HansV]

If you want to exclude hidden sheets, you could add a check

If wsh.Visible = xlSheetVisible Then
...
End If

within the For ... Next loop.

[ABabeNChrist]

OK I have added the if then and that seems to work for hidden sheets. Upon further testing I've now noticed that if a sheet doesn't have a picture it will open the Compress Picture dialog for that sheet, can a sheet with no picture also be excluded

Code: Select all

Private Sub CommandButton4_Click()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim f As Boolean

    Application.ScreenUpdating = False

    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            wsh.Select
            f = False
            For Each shp In wsh.Shapes
                Select Case shp.Type
                Case msoLinkedPicture, msoPicture
                    shp.Select Replace:=Not f
                    f = True
                End Select
            Next shp

            With Selection
                Application.EnableCancelKey = xlDisabled
                Application.SendKeys "aw{ENTER}{ESC}{ESC}", False
                Application.SendKeys "%(oe)~{TAB}~"
                Application.CommandBars.ExecuteMso "PicturesCompress"
                DoEvents
                Application.EnableCancelKey = xlInterrupt
            End With
            wsh.Range("A1").Select
        End If
    Next wsh

    Application.ScreenUpdating = True
End Sub

[HansV]

You could prevent that as follows:

Code: Select all

Sub CommandButton4_Click()
    Dim wsh As Worksheet
    Dim shp As Shape
    Dim f As Boolean

    Application.ScreenUpdating = False

    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            wsh.Select
            f = False
            For Each shp In wsh.Shapes
                Select Case shp.Type
                Case msoLinkedPicture, msoPicture
                    shp.Select Replace:=Not f
                    f = True
                End Select
            Next shp

            ' Only continue if the sheet contains pictures
            If f Then
                With Selection
                    Application.EnableCancelKey = xlDisabled
                    Application.SendKeys "aw{ENTER}{ESC}{ESC}", False
                    Application.SendKeys "%(oe)~{TAB}~"
                    Application.CommandBars.ExecuteMso "PicturesCompress"
                    DoEvents
                    Application.EnableCancelKey = xlInterrupt
                End With
                wsh.Range("A1").Select
            End If
        End If
    Next wsh

    Application.ScreenUpdating = True
End Sub

[ABabeNChrist]

Thank you Hans, I'll play around with this a bit and put it through some testing, so far its working good
Have a great day/evening, thanks again

[ABabeNChrist]

I’m having a problem with placement of final message bx, I don’t want it to display if users cancels.

Code: Select all

MsgBox "All opened page have been compressed, Now select Save As You Go button on toolbar"

Also I it seems my ErrorHandler message always appears.
Here is the code below

Code: Select all

    Dim wsh As Worksheet
    Dim shp As Shape
    Dim f As Boolean
    MsgBox "Select Compression size, select check box that says, Apply only to this picture, and then continue to press the OK button as it goes though all opened pages"
    Application.ScreenUpdating = False

    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            wsh.Select
            f = False
            For Each shp In wsh.Shapes
                Select Case shp.Type
                Case msoLinkedPicture, msoPicture
                    shp.Select Replace:=Not f
                    f = True
                End Select
            Next shp

            On Error GoTo ErrorHandler

            ' Only continue if the sheet contains pictures
            If f Then
                With Selection
                    Application.EnableCancelKey = xlDisabled
                    Application.SendKeys "aw{ENTER}{ESC}{ESC}", False
                    Application.SendKeys "%(oe)~{TAB}~"
                    Application.CommandBars.ExecuteMso "PicturesCompress"
                    DoEvents
                    Application.EnableCancelKey = xlInterrupt
                End With
                wsh.Range("A1").Select
            End If
        End If
    Next wsh

    Application.ScreenUpdating = True
    MsgBox "All opened page have been compressed, Now select Save As You Go button on toolbar"

ErrorHandler:     MsgBox "Error occurred try once more"

[HansV]

Insert a line

Code: Select all

    Exit Sub

immediately above the ErrorHandler: line.

[ABabeNChrist]

Perfect, thank you Hans as always