Compress Pictures with VBA

[Micha]

Hi everbody,

I tried to compress pictures with a makro. If I do manually, format
graphic --> compress --> web/monitor 96 dpi, it works, but when I
record this with the makro recorder and play it, it doesen't work.
Here is the code which I record:

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#

So can anybody help me, how I can compress an image with VBA???

Thanks for your answers??

Micha

 

[NickHK]

Micha,
I have just changed to using XL2002. Recording a macro of compressing a
resized graphic gives output that contained nothing part from
ActiveSheet.Shapes("Picture 2").Select
So I'm not sure at the moment.

However, do you have a Picture selected before running the code, as you are
working the Selection object.

NickHK

 

[NickHK]

Micha,
I have just changed to using XL2002. Recording a macro of compressing a
resized graphic gives output that contained nothing part from
ActiveSheet.Shapes("Picture 2").Select
So I'm not sure at the moment.

However, do you have a Picture selected before running the code, as you are
working the Selection object.

NickHK

 

[Micha]

Hi NickHK,

I start the record and selectcs one picture and he should do this for
every picture in the document, here is my complete code:

Sub bildEinfuegen()
Dim bild As Variant
Dim pfad As String
Dim i As Integer
Dim name As String
Dim orgHoehe As Double
Dim orgBreite As Double
Dim neueBreite As Double
Dim spalte As Integer

neueBreite = 10 'in cm
neueBreite = Application.CentimetersToPoints(neueBreite)
spalte = 1

pfad = "D:\Austausch\"

For i = 1 To 3
name = "DB2 V7_" & i & ".jpg"

bild = pfad & name
Cells(1, spalte).Select

ActiveSheet.Pictures.Insert(bild).Select


orgHoehe = Selection.ShapeRange.Height
orgBreite = Selection.ShapeRange.Width

Selection.ShapeRange.Width = neueBreite
Selection.ShapeRange.Height = orgHoehe * neueBreite / orgHoehe

.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#

spalte = spalte + 3

Next i
End Sub


we are using Excel 2003