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

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


"(E-Mail Removed)" wrote:

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

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

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



On Jun 22, 4:05*am, Joel <J...@discussions.microsoft.com> wrote:
> 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
>
>
>
> "marc...@excite.com" wrote:
>
> > 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- Hide quoted text -
>
> - Show quoted text -

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.

"(E-Mail Removed)" wrote:

> 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
>
> *********************************************
>
>
>
> On Jun 22, 4:05 am, Joel <J...@discussions.microsoft.com> wrote:
> > 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
> >
> >
> >
> > "marc...@excite.com" wrote:
> >
> > > 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- Hide quoted text -
> >
> > - Show quoted text -
>
>

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.





On Jun 23, 6:45*pm, Joel <J...@discussions.microsoft.com> wrote:
> 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 thepicturea little
> bit smaller. *Experiment with these numbers after you eliminate the twoIf
> statemnts above.
>
>
>
> "marc...@excite.com" wrote:
> > 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
>
> > *********************************************
>
> > On Jun 22, 4:05 am, Joel <J...@discussions.microsoft.com> wrote:
> > > 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
>
> > > "marc...@excite.com" wrote:
>
> > > > 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 thenCROPthe width from the RIGHT and the LEFT to the
> > > > samesizeas the Height.
> > > > And same for the height, if the Height is longer than the width then
> > > >Cropfrom the TOP and the BOTTOM to the samesizeas 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- Hide quoted text -
>
> > > - Show quoted text -- Hide quoted text -
>
> - Show quoted text -

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


"(E-Mail Removed)" wrote:

> 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.
>
>
>
>
>
> On Jun 23, 6:45 pm, Joel <J...@discussions.microsoft.com> wrote:
> > 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 thepicturea little
> > bit smaller. Experiment with these numbers after you eliminate the two If
> > statemnts above.
> >
> >
> >
> > "marc...@excite.com" wrote:
> > > 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
> >
> > > *********************************************
> >
> > > On Jun 22, 4:05 am, Joel <J...@discussions.microsoft.com> wrote:
> > > > 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
> >
> > > > "marc...@excite.com" wrote:
> >
> > > > > 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 thenCROPthe width from the RIGHT and the LEFT to the
> > > > > samesizeas the Height.
> > > > > And same for the height, if the Height is longer than the width then
> > > > >Cropfrom the TOP and the BOTTOM to the samesizeas 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- Hide quoted text -
> >
> > > > - Show quoted text -- Hide quoted text -
> >
> > - Show quoted text -
>
>