VBA: issue fitting picture to cell range

[nmgmarques]

Hi all.

Over the last few months I have been scrounging the intertubes trying to make/modify a VBA script that will resize and fit my pictures into a certain cell range. The function (named FitPic) is working nicely so far and mostly is doing what is intended of it. You can see the code below. However, from time to time I get a picture that will bleed out of the range (example posted below). In this example the width is larger than the height, thus my function has fit the picture to match the width and has done so correctly. But the image in question, after being scaled down to it's width, is still higher than the cell range and thus bleeds out. My question: how can I script it to take this into account and correct if necessary. This could happen both to the height as it could happen to the width. I am guessing I have to implement some sort of check after check or whatnot but my VB skills are so limited I just can't figure out a solution. Please, anyone, help?

Still new to the forums so I can't post links but the image of the "bleeder" can be found at yfrog.com/z/b9mdwkj and as you can see the lower tip of the image is reaching beyond the lower end of the range.

This is just the function I am calling to resize and set the images but if necessary I can post the entire script.

[vba]Function FitPic()
Set pic = ActiveSheet.Pictures.Insert(absPath)
If pic.Width > pic.Height Then
'check if the picture's width is larger than its height
With pic
.ShapeRange.LockAspectRatio = msoTrue
'keep original aspect ratio
.Width = Rng.Width - 1
'pictures' width is the larger height, by this line it fits exactly into range width
.Left = Rng.Left + 1
'position at left range border
.Top = Rng.Top + ((Rng.Height - pic.Height) / 2)
'position in center of range height
.Placement = xlMoveAndSize
.PrintObject = True
'make sure picture gets printed
End With
Else
'picture's height is larger than its width
With pic
.ShapeRange.LockAspectRatio = msoTrue
'same as some lines above
.Top = Rng.Top + 1
'position at upper border of the range
.Height = Rng.Height - 1
'picture's heigth is larger than its width, this line makes it exactly fit int range height
.Left = Rng.Left + ((Rng.Width - pic.Width) / 2)
'position in center of range width
.Placement = xlMoveAndSize
.PrintObject = True
End With
End If
End Function[/vba]

[mdmackillop]

This site doesn't like Chrome!

[nmgmarques]

This site doesn't like Chrome!

Not using Chrome, rather Firefox. Please explain why so I can correct whatever issue there might be.

[p45cal]

The function seems to adjust the picture size according to whether its height is greater than its width. It doesn't look at the aspect ratio of the range it's got to fit into. So without getting into the minutiae, you need to compare the aspect ratio of the picture with the aspect ratio of the range, then chose one action or the other when resizing the picture.
It might be as simple as seeing which of these two is larger:
rng.height/rng.width
and:
pic.height/pic.width

So perhaps replace:
If pic.Width > pic.Height Then
with say:
If (rng.height/rng.width)>(pic.height/pic.width) then
but I haven't looked too closely whether that > should be < or not.

[nmgmarques]

The function seems to adjust the picture size according to whether its height is greater than its width. It doesn't look at the aspect ratio of the range it's got to fit into. So without getting into the minutiae, you need to compare the aspect ratio of the picture with the aspect ratio of the range, then chose one action or the other when resizing the picture.
It might be as simple as seeing which of these two is larger:
rng.height/rng.width
and:
pic.height/pic.width

So perhaps replace:
If pic.Width > pic.Height Then
with say:
If (rng.height/rng.width)>(pic.height/pic.width) then
but I haven't looked too closely whether that > should be < or not.

I don't have the complete script here with me, but from what I was able to test this seems to be the solution Thanks!