Photo size problem

ABabeNChrist · Post by **ABabeNChrist** » 09 Apr 2014, 16:23

Lately I have been having problems with the size of my completed report from excel to pdf.
I know it has something do with the photo sizes that are added in workbook. My photos are usually around 2 mb (each) I then compress to 25% using FastStone before inserting. Generally a workbook (completed report) is around 10 to 15 mb (approximately 50 photos) and the pdf report from 2 to 5 mb, which of course totally acceptable.

But some completed workbooks will be the normal/average size, but the pdf report is almost equal size with the workbook. I’m thinking when I adjust the photo size after I insert that maybe this changes the photo size.

Is there any type of code that could be run during the printing process to compress/reduce the photos

Post by **HansV** » 09 Apr 2014, 16:43

Does this help? How to Programatically Compress Pictures/Images in Excel using VBA

ABabeNChrist · Post by **ABabeNChrist** » 09 Apr 2014, 17:11

Here is my current code for printing

Code: Select all

Private Sub CommandButton4_Click()
    Dim blnSelected As Boolean
    Dim wsh As Worksheet
    Dim wshI As Worksheet
    Dim lngPage As Long
    Dim lngRow As Long
    
    ActiveWorkbook.Protect PassWord:="", Structure:=False, Windows:=False

    Application.ScreenUpdating = False
    
    Sheets("Inspection Report Directory").Visible = xlSheetVisible
    Sheets("Inspection Agreement").Visible = xlSheetVisible


    Set wshI = Worksheets("Inspection Report Directory")
    lngPage = 1
    lngRow = 6
    wshI.Cells.ClearContents
    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            Select Case wsh.Name
                Case "Email", "_", "Invoice", "Report Information Log", "Realtors", _
                    "Format Comment", "Color Setting", "Inspection Log"
                    ' Do nothing
                Case Else
                    wshI.Range("B" & lngRow) = wsh.Name
                    wshI.Range("C" & lngRow) = lngPage
                    lngRow = lngRow + 1
                    wsh.Activate
                    lngPage = lngPage + Application.ExecuteExcel4Macro("Get.Document(50)")
            End Select
        End If
    Next wsh
    Sheets("Inspection Report Directory").Range("B3").Value = " Inspection Report Directory "
    Sheets("Inspection Report Directory").Range("B5").Value = " Inspected locations "
    Sheets("Inspection Report Directory").Range("C5").Value = " Page # "

    

    If CheckBox1.Value And Sheets("Cover Page").Visible = xlSheetVisible Then
        Sheets("Cover Page").Select Replace:=True
        blnSelected = True
    End If
    If CheckBox2.Value And Sheets("Client Information").Visible = xlSheetVisible Then
        Sheets("Client Information").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox3.Value And Sheets("Utilities").Visible = xlSheetVisible Then
        Sheets("Utilities").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox4.Value And Sheets("Grounds").Visible = xlSheetVisible Then
        Sheets("Grounds").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox5.Value And Sheets("Structural Systems").Visible = xlSheetVisible Then
        Sheets("Structural Systems").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox6.Value And Sheets("Detached Structure").Visible = xlSheetVisible Then
        Sheets("Detached Structure").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox7.Value And Sheets("Roof & Attic").Visible = xlSheetVisible Then
        Sheets("Roof & Attic").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox8.Value And Sheets("Fireplace & Chimney").Visible = xlSheetVisible Then
        Sheets("Fireplace & Chimney").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox10.Value And Sheets("Bathroom(s)").Visible = xlSheetVisible Then
        Sheets("Bathroom(s)").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox12.Value And Sheets("Kitchen").Visible = xlSheetVisible Then
        Sheets("Kitchen").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox13.Value And Sheets("Kitchen Appliances").Visible = xlSheetVisible Then
        Sheets("Kitchen Appliances").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox14.Value And Sheets("Heating and Cooling").Visible = xlSheetVisible Then
        Sheets("Heating and Cooling").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox15.Value And Sheets("Water Heater").Visible = xlSheetVisible Then
        Sheets("Water Heater").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox16.Value And Sheets("Pool Spa").Visible = xlSheetVisible Then
        Sheets("Pool Spa").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox17.Value And Sheets("Summary").Visible = xlSheetVisible Then
        Sheets("Summary").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox18.Value And Sheets("Additional Photos").Visible = xlSheetVisible Then
        Sheets("Additional Photos").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox19.Value Then
        Sheets("Inspection Report Directory").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox20.Value Then
        Sheets("Inspection Agreement").Select Replace:=False
        blnSelected = True
    End If

    If blnSelected = True Then
        
        ActiveWindow.SelectedSheets.Application.Dialogs(xlDialogPrint).Show
        Unload Me
        Unload UserForm4
        Sheets("Inspection Report Directory").Visible = xlSheetHidden
        Sheets("Inspection Agreement").Visible = xlSheetHidden
        Sheets("Cover Page").Activate
        Sheets("Cover Page").Range("A1").Select
        ActiveWorkbook.Protect PassWord:="", Structure:=True, Windows:=True

    Else
        MsgBox "No check boxes were selected"

    End If
    Application.ScreenUpdating = True
    ActiveSheet.Select

End Sub

Here is the VBA suggestion

Code: Select all

Sub Compress_PIX()
    Dim octl As CommandBarControl
    With Selection
        Set octl = Application.CommandBars.FindControl(ID:=6382)
        Application.SendKeys "%e~"
        Application.SendKeys "%a~"
        octl.Execute
    End With
End Sub

can this be applied as shown below

Code: Select all

Private Sub CommandButton4_Click()
    Dim blnSelected As Boolean
    Dim wsh As Worksheet
    Dim wshI As Worksheet
    Dim lngPage As Long
    Dim lngRow As Long
    Dim octl As CommandBarControl

    ActiveWorkbook.Protect PassWord:="", Structure:=False, Windows:=False

    With Selection
        Set octl = Application.CommandBars.FindControl(ID:=6382)
        Application.SendKeys "%e~"
        Application.SendKeys "%a~"
        octl.Execute
    End With


    Application.ScreenUpdating = False

    Sheets("Inspection Report Directory").Visible = xlSheetVisible
    Sheets("Inspection Agreement").Visible = xlSheetVisible


    Set wshI = Worksheets("Inspection Report Directory")
    lngPage = 1
    lngRow = 6
    wshI.Cells.ClearContents
    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            Select Case wsh.Name
            Case "Email", "_", "Invoice", "Report Information Log", "Realtors", _
                 "Format Comment", "Color Setting", "Inspection Log"
                ' Do nothing
            Case Else
                wshI.Range("B" & lngRow) = wsh.Name
                wshI.Range("C" & lngRow) = lngPage
                lngRow = lngRow + 1
                wsh.Activate
                lngPage = lngPage + Application.ExecuteExcel4Macro("Get.Document(50)")
            End Select
        End If
    Next wsh
    Sheets("Inspection Report Directory").Range("B3").Value = " Inspection Report Directory "
    Sheets("Inspection Report Directory").Range("B5").Value = " Inspected locations "
    Sheets("Inspection Report Directory").Range("C5").Value = " Page # "



    If CheckBox1.Value And Sheets("Cover Page").Visible = xlSheetVisible Then
        Sheets("Cover Page").Select Replace:=True
        blnSelected = True
    End If
    If CheckBox2.Value And Sheets("Client Information").Visible = xlSheetVisible Then
        Sheets("Client Information").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox3.Value And Sheets("Utilities").Visible = xlSheetVisible Then
        Sheets("Utilities").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox4.Value And Sheets("Grounds").Visible = xlSheetVisible Then
        Sheets("Grounds").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox5.Value And Sheets("Structural Systems").Visible = xlSheetVisible Then
        Sheets("Structural Systems").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox6.Value And Sheets("Detached Structure").Visible = xlSheetVisible Then
        Sheets("Detached Structure").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox7.Value And Sheets("Roof & Attic").Visible = xlSheetVisible Then
        Sheets("Roof & Attic").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox8.Value And Sheets("Fireplace & Chimney").Visible = xlSheetVisible Then
        Sheets("Fireplace & Chimney").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox10.Value And Sheets("Bathroom(s)").Visible = xlSheetVisible Then
        Sheets("Bathroom(s)").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox12.Value And Sheets("Kitchen").Visible = xlSheetVisible Then
        Sheets("Kitchen").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox13.Value And Sheets("Kitchen Appliances").Visible = xlSheetVisible Then
        Sheets("Kitchen Appliances").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox14.Value And Sheets("Heating and Cooling").Visible = xlSheetVisible Then
        Sheets("Heating and Cooling").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox15.Value And Sheets("Water Heater").Visible = xlSheetVisible Then
        Sheets("Water Heater").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox16.Value And Sheets("Pool Spa").Visible = xlSheetVisible Then
        Sheets("Pool Spa").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox17.Value And Sheets("Summary").Visible = xlSheetVisible Then
        Sheets("Summary").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox18.Value And Sheets("Additional Photos").Visible = xlSheetVisible Then
        Sheets("Additional Photos").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox19.Value Then
        Sheets("Inspection Report Directory").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox20.Value Then
        Sheets("Inspection Agreement").Select Replace:=False
        blnSelected = True
    End If

    If blnSelected = True Then

        ActiveWindow.SelectedSheets.Application.Dialogs(xlDialogPrint).Show
        Unload Me
        Unload UserForm4
        Sheets("Inspection Report Directory").Visible = xlSheetHidden
        Sheets("Inspection Agreement").Visible = xlSheetHidden
        Sheets("Cover Page").Activate
        Sheets("Cover Page").Range("A1").Select
        ActiveWorkbook.Protect PassWord:="", Structure:=True, Windows:=True

    Else
        MsgBox "No check boxes were selected"

    End If
    Application.ScreenUpdating = True
    ActiveSheet.Select

End Sub

Post by **HansV** » 09 Apr 2014, 18:19

It's worth a try!

ABabeNChrist · Post by **ABabeNChrist** » 09 Apr 2014, 20:39

I tried it on a workbook in question and there was no change. Nothing seem to happen?

Post by **HansV** » 09 Apr 2014, 20:50

I fear you'll have to reduce the height and width, as well as the quality of the pictures before inserting them into the workbook. The file size of a reasonable quality jpg of, say, 480x320 pixels needn't be larger than 50-75 KB.

Reduce.jpg

ABabeNChrist · Post by **ABabeNChrist** » 09 Apr 2014, 21:06

The only thing I found that worked was to take a screen shoot of any over sized photos then open paint, paste, crop (picture only), then re-paste cropped picture in new paint and save as jpeg. The picture can go from 2mb to 36kb, but the problem is it can take way to much time when you have 20+ photos

Post by **HansV** » 09 Apr 2014, 21:11

You don't need Paint for that - the screenshot in my previous reply is the dialog that appears if you click Options... in the Save As dialog of FastStone Capture. Resizing and cropping can also be done within this utility. I assume that other screen capture utilities have similar features.

steveh · Post by **steveh** » 10 Apr 2014, 06:16

ABabeNChrist wrote:The only thing I found that worked was to take a screen shoot of any over sized photos then open paint, paste, crop (picture only), then re-paste cropped picture in new paint and save as jpeg. The picture can go from 2mb to 36kb, but the problem is it can take way to much time when you have 20+ photos

Morning

for what it is worth I use Shrink Pic which is easy to use and if set to mid compression will reduce my pictrues from my camera which are on aveage 15mb to a size between 100 and 150kb without much visual loss of quality (you can see an example in Scuttlebutt in my recent post Personal Boast - Part 2).

I find that having Shrink Pic running in the system tray and emailing myself a batch of pictures is the quickest any easiest way.

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 13:09

I was trying different ways last night and I think I found a solution. What I did was open a workbook in question that was 14mb and contained numerous photos on various sheets (totaling approximately 70 photos). I would then go sheet by sheet selecting all photos (using Ctrl), then double clicking last photo to open Picture tool format,
Then selecting “Compress Pictures”
Checkbox to “Apply to selected photos”
Make my selections on “Compress Settings”

Compress Settings.jpg

Then ok ok

After going through each sheet I was able to reduce the workbook and finished pdf
The workbook was 14mb and now 6mb
The pdf file was 12mb and now 3mb
Even though this process was successful it was a slow process.
I’m thinking the code to compress probably works only when the photos are selected, so would there be a way to select all inserted photos using vba before running code.

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 13:13

steveh wrote:
ABabeNChrist wrote:Morning

for what it is worth I use Shrink Pic which is easy to use and if set to mid compression will reduce my pictrues from my camera which are on aveage 15mb to a size between 100 and 150kb without much visual loss of quality (you can see an example in Scuttlebutt in my recent post Personal Boast - Part 2).

I find that having Shrink Pic running in the system tray and emailing myself a batch of pictures is the quickest any easiest way.

Thanks Steve, I’m always looking for faster easier ways

Post by **HansV** » 10 Apr 2014, 13:34

See if this works for you:

Code: Select all

Private Sub CommandButton4_Click()
    Dim blnSelected As Boolean
    Dim wsh As Worksheet
    Dim wshI As Worksheet
    Dim lngPage As Long
    Dim lngRow As Long
    Dim oCtl As CommandBarControl

    ActiveWorkbook.Protect Password:="", Structure:=False, Windows:=False

    On Error Resume Next
    For Each wsh In Worksheets
        If wsh.Shapes.Count > 0 Then
            wsh.Shapes.SelectAll
            With Selection
                Set oCtl = Application.CommandBars.FindControl(ID:=6382)
                Application.SendKeys "%e~"
                Application.SendKeys "%a~"
                oCtl.Execute
            End With
        End If
    Next wsh
    On Error GoTo 0

    Application.ScreenUpdating = False

    Sheets("Inspection Report Directory").Visible = xlSheetVisible
    Sheets("Inspection Agreement").Visible = xlSheetVisible

    Set wshI = Worksheets("Inspection Report Directory")
    lngPage = 1
    lngRow = 6
    wshI.Cells.ClearContents
    For Each wsh In Worksheets
        If wsh.Visible = xlSheetVisible Then
            Select Case wsh.Name
            Case "Email", "_", "Invoice", "Report Information Log", "Realtors", _
                 "Format Comment", "Color Setting", "Inspection Log"
                ' Do nothing
            Case Else
                wshI.Range("B" & lngRow) = wsh.Name
                wshI.Range("C" & lngRow) = lngPage
                lngRow = lngRow + 1
                wsh.Activate
                lngPage = lngPage + Application.ExecuteExcel4Macro("Get.Document(50)")
            End Select
        End If
    Next wsh

    Sheets("Inspection Report Directory").Range("B3").Value = " Inspection Report Directory "
    Sheets("Inspection Report Directory").Range("B5").Value = " Inspected locations "
    Sheets("Inspection Report Directory").Range("C5").Value = " Page # "

    If CheckBox1.Value And Sheets("Cover Page").Visible = xlSheetVisible Then
        Sheets("Cover Page").Select Replace:=True
        blnSelected = True
    End If
    If CheckBox2.Value And Sheets("Client Information").Visible = xlSheetVisible Then
        Sheets("Client Information").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox3.Value And Sheets("Utilities").Visible = xlSheetVisible Then
        Sheets("Utilities").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox4.Value And Sheets("Grounds").Visible = xlSheetVisible Then
        Sheets("Grounds").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox5.Value And Sheets("Structural Systems").Visible = xlSheetVisible Then
        Sheets("Structural Systems").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox6.Value And Sheets("Detached Structure").Visible = xlSheetVisible Then
        Sheets("Detached Structure").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox7.Value And Sheets("Roof & Attic").Visible = xlSheetVisible Then
        Sheets("Roof & Attic").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox8.Value And Sheets("Fireplace & Chimney").Visible = xlSheetVisible Then
        Sheets("Fireplace & Chimney").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox10.Value And Sheets("Bathroom(s)").Visible = xlSheetVisible Then
        Sheets("Bathroom(s)").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox12.Value And Sheets("Kitchen").Visible = xlSheetVisible Then
        Sheets("Kitchen").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox13.Value And Sheets("Kitchen Appliances").Visible = xlSheetVisible Then
        Sheets("Kitchen Appliances").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox14.Value And Sheets("Heating and Cooling").Visible = xlSheetVisible Then
        Sheets("Heating and Cooling").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox15.Value And Sheets("Water Heater").Visible = xlSheetVisible Then
        Sheets("Water Heater").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox16.Value And Sheets("Pool Spa").Visible = xlSheetVisible Then
        Sheets("Pool Spa").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox17.Value And Sheets("Summary").Visible = xlSheetVisible Then
        Sheets("Summary").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox18.Value And Sheets("Additional Photos").Visible = xlSheetVisible Then
        Sheets("Additional Photos").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox19.Value Then
        Sheets("Inspection Report Directory").Select Replace:=False
        blnSelected = True
    End If
    If CheckBox20.Value Then
        Sheets("Inspection Agreement").Select Replace:=False
        blnSelected = True
    End If

    If blnSelected = True Then
        ActiveWindow.SelectedSheets.Application.Dialogs(xlDialogPrint).Show
        Unload Me
        Unload UserForm4
        Sheets("Inspection Report Directory").Visible = xlSheetHidden
        Sheets("Inspection Agreement").Visible = xlSheetHidden
        Sheets("Cover Page").Activate
        Sheets("Cover Page").Range("A1").Select
        ActiveWorkbook.Protect Password:="", Structure:=True, Windows:=True
    Else
        MsgBox "No check boxes were selected"
    End If
    Application.ScreenUpdating = True
    ActiveSheet.Select
End Sub

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 14:48

How can I de-select all shapes after compressing and how to select 96dpi instead of 200dpi

Post by **HansV** » 10 Apr 2014, 15:00

Code: Select all

        If wsh.Shapes.Count > 0 Then
            wsh.Shapes.SelectAll
            With Selection
                Set oCtl = Application.CommandBars.FindControl(ID:=6382)
                Application.SendKeys "%w%e~"
                Application.SendKeys "%a~"
                oCtl.Execute
            End With
            ActiveWindow.RangeSelection.Select
        End If

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 15:59

When I run the code there seems to be little to no changes in size of workbook and pdf. It seems the code does not compress all photos in workbook, I’m thinking only on activesheet.

But if I just use the code below to select all shapes and then go to each sheet

Code: Select all

    Dim wsh As Worksheet
    ActiveWorkbook.Protect PassWord:="", Structure:=False, Windows:=False
    For Each wsh In Worksheets
        If wsh.Shapes.Count > 0 Then
            wsh.Shapes.SelectAll
        End If
    Next wsh

Then selecting “Compress Pictures” on toolbar
Checkbox to “Apply to selected photos”
Make my selections on “Compress Settings”
Once again is compresses great
I tried on a different workbook
Old size was 13mb new size 5.2 mb
Old pdf 9.6mb new 1.2mb

Post by **HansV** » 10 Apr 2014, 16:05

I'm out of ideas, sorry.

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 16:26

I want to try something, is there vba to open “Compress Pictures” dialog
I was thinking of adding a button on my UI Editor toolbar that will select shapes on activesheet then open Compress picture dialog and make my selections from there. It would defiantly speed thing up

Post by **HansV** » 10 Apr 2014, 16:34

The lines

Set oCtl = Application.CommandBars.FindControl(ID:=6382)
oCtl.Execute

display the Compress Pictures dialog.

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 16:43

Thank you Hans, I'll play around and see what I can do

ABabeNChrist · Post by **ABabeNChrist** » 10 Apr 2014, 18:22

I have also posted this thread at Excel Forum and will update if solved
http://www.excelforum.com/excel-program ... hotos.html

Eileen's Lounge

Photo size problem

Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem

Re: Photo size problem