Crop pictures in excel,,,

[marc747]

Hi,
I have a Macro that inserts pictures in excel, but my pictures are
some in different sizes some have the width long and some the height
is long.
What I need is a macro that sizes the pictures. If the width is longer
than the height then CROP the width from the RIGHT and the LEFT to the
same size as the Height.
And same for the height, if the Height is longer than the width then
Crop from the TOP and the BOTTOM to the same size as the Width.
This is the part of the Macro that I have now.

If Pict.Width > Pict.Height Then
Crop = (CellWidth - Pict.Width) / 2
Pict.ShapeRange.PictureFormat.CropLeft = 150
Pict.ShapeRange.PictureFormat.CropRight = 150
Else
Crop = (CellHeight - Pict.Height) / 2
Pict.ShapeRange.PictureFormat.CropTop = 150
Pict.ShapeRange.PictureFormat.CropBottom = 150
End If

 

[Joel]

Here is two slightly different solutions

If pict.Width > pict.Height Then
If pict.Width > CellWidth Then
If pict.Width > 150 Then
Crop = (pict.Width - CellWidth) / 2
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
End If
End If
Else
If CellHeight > pict.Height Then
If pict.Height > 150 Then
Crop = Abs(pict.Height - CellHeight) / 2
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If
End If
End If

If pict.Width > pict.Height Then
If pict.Width > 150 Then
Crop = (pict.Width - 150) / 2
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
End If
Else
If pict.Height > 150 Then
Crop = (pict.Height - 150) / 2
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If
End If

 

[marc747]

I am still having some difficulty, everything works perfect except the
croping of the pictures, Some pictures get croped a little, some are
still very long, it is just not right.
The pictures are not suppose to go cross the cell width or cell height
and at the same time should keep the ratio. Below is the complete
macro that I have. can you see what we can do to make this work.
Thanks.

*****************************

Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each Cell In Range("B4:IV4")
If Cell <> "" Then
Cell.Offset(-3, 0).ClearContents
PictureFound = Dir(Cell.Value)
If PictureFound <> "" Then

Set pict = ActiveSheet.Pictures. _
Insert(Cell.Value)
Else
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
End If
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pictwidth = pict.Width
CellWidth = Cells(9, Cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, Cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, Cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, Cell.Column).Top + (HeightBorder / 1.8)

If pict.Width > pict.Height Then
If pict.Width > CellWidth Then
If pict.Width > 150 Then
Crop = (pict.Width - CellWidth) / 1.8
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop
End If
End If
Else
If CellHeight > pict.Height Then
If pict.Height > 150 Then
Crop = Abs(pict.Height - CellHeight) / 1.8
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop
End If
End If
End If

End If 'new line
Next Cell
Exit Sub 'new line

End Sub

*********************************************

 

[Joel]

First I would eliminnate the following two if statements. I don't think they
add any value to the code

If pict.Width > 150 Then
If pict.Height > 150 Then

Second I would change the divides by 1.8 to 2.2. 1.8 will make the pictures
larger than the width/height of the cell. 2.2 will make the picture a little
bit smaller. Experiment with these numbers after you eliminate the two If
statemnts above.

 

[marc747]

Hi,
Everything works good, but I faced with one issue which was related to
the picture file, maybe a format or something else,
when I ran the Macro and it came to this file the macro stopped
because something was wrong with the picture file. Now my question is
can we add a line to the Macro to make it not stop, so that if it
finds such error instead of stopping just skip that one and go to the
next.
Thanks.

 

[Joel]

try thses changes. I don't know if the code is your lastest, so make sue it
is the same as the code you are using


Sub add_pictures()

Const PictureHeight = 120
Folder = "O:\MERCHGRP\AAB\pics\Mpics\"
FName = "Picture_not_Available.jpg"
DefaultPicture = Folder & FName

Application.ScreenUpdating = False

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastCol = Cells(4, Columns.Count).End(xlToLeft).Row
Rows(9).RowHeight = PictureHeight

For Each cell In Range("B4:IV4")
If cell <> "" Then
cell.Offset(-3, 0).ClearContents
PictureFound = Dir(cell.Value)
Set pict = Nothing '<= added
If PictureFound <> "" Then

Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
Else
On Error Resume Next '<=added
Set pict = ActiveSheet.Pictures. _
Insert(DefaultPicture)
On Error GoTo 0 '<=added
End If
If pict Is Nothing Then '<=added
MsgBox ("Could not add picture : " & cell.Value)
Else
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pictwidth = pict.Width
CellWidth = Cells(9, cell.Column).Width
WidthBorder = CellWidth - pictwidth
pict.Left = Cells(9, cell.Column).Left + (WidthBorder / 1.8)

PictHeight = pict.Height
CellHeight = Cells(9, cell.Column).Height
HeightBorder = CellHeight - PictHeight
pict.Top = Cells(9, cell.Column).Top + (HeightBorder / 1.8)

If pict.Width > pict.Height Then
If pict.Width > CellWidth Then

Crop = (pict.Width - CellWidth) / 1.8
pict.ShapeRange.PictureFormat.CropLeft = Crop
pict.ShapeRange.PictureFormat.CropRight = Crop

End If
Else
If CellHeight > pict.Height Then

Crop = Abs(pict.Height - CellHeight) / 1.8
pict.ShapeRange.PictureFormat.CropTop = Crop
pict.ShapeRange.PictureFormat.CropBottom = Crop

End If
End If
End If
End If 'new line
Next cell
Exit Sub 'new line

End Sub