Ron C?ppers
01-17-2009, 09:53 AM
Hi there,
I want to automatticaly compress pictures i added to my worksheet. I used the next macro, it runs but does not compress the pictures.
Has anyone got a solution?
Sub CompressPictures()
' Macro to compress all pictures
' Last change 7-1-2009
Dim DrObj
Dim Pict
Set DrObj = ActiveSheet.DrawingObjects
For Each Pict In DrObj
If Left(Pict.Name, 7) = "Picture" Then
Pict.Select
'With Selection
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
'End With
End If
Next
End Sub
I want to automatticaly compress pictures i added to my worksheet. I used the next macro, it runs but does not compress the pictures.
Has anyone got a solution?
Sub CompressPictures()
' Macro to compress all pictures
' Last change 7-1-2009
Dim DrObj
Dim Pict
Set DrObj = ActiveSheet.DrawingObjects
For Each Pict In DrObj
If Left(Pict.Name, 7) = "Picture" Then
Pict.Select
'With Selection
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
'End With
End If
Next
End Sub