How to stretch image cover specific cell?

E

Eric

Does anyone have any suggestions on how to edit the following code to stretch
image fit for specific cell's size?

I would like to locate the image cover the cell from B10 (left top corner)
to C 13 ( right bottom corner),
Does anyone have any suggestions on how to resize the and fit within
specific cells?
Thanks in advance for any suggestions
Eric

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPic As Object
If Target.Address = "$A$1" Then
On Error Resume Next
Set myPic = ActiveSheet.Pictures(1)
On Error GoTo 0
If Not myPic Is Nothing Then myPic.Delete

If Range("A1") = 1 Then
ActiveSheet.Pictures.Insert ("C:\TempPic.JPG")
Else
ActiveSheet.Pictures.Insert ("C:\TempPic2.JPG")
End If

End If
End Sub
 
O

OssieMac

Hi Eric,

Firstly, you may not be able to completely resize the picture because I
think that they retain proportion. With my tesing of the following code the
width seems to take precedence over the height and therefore the top, left
and width were correct but the height was oversize even though the correct
height was calculated.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPic As Object
Dim dblTop As Double
Dim dblLeft As Double
Dim dblHeight As Double
Dim dblWidth As Double

If Target.Address = "$A$1" Then
On Error Resume Next
Set myPic = ActiveSheet.Pictures(1)
On Error GoTo 0
If Not myPic Is Nothing Then myPic.Delete

If Range("A1") = 1 Then
Set myPic = ActiveSheet.Pictures.Insert("C:\TempPic.JPG")
Else
Set myPic = ActiveSheet.Pictures.Insert("C:\TempPic2.JPG")
End If

dblTop = Cells(10, "B").Top
dblLeft = Cells(10, "B").Left
dblHeight = Cells(14, "B").Top - Cells(10, "B").Top
dblWidth = Cells(10, "D").Left - Cells(10, "B").Left

With myPic
.Top = dblTop
.Left = dblLeft
.Height = dblHeight
.Width = dblWidth
End With

End If
 
O

OssieMac

Hi again Eric,

I found out how to Unlock / Lock the aspect ratio so you can accuratesly
align the picture within the required cells. Note that it could cause some
distortion of the picture.

With myPic
.ShapeRange.LockAspectRatio = msoFalse '/ msoTrue
.Top = dblTop
.Left = dblLeft
.Height = dblHeight
.Width = dblWidth
End With
 
E

Eric

Thank you very much for your suggestions
I have tried your code on a new worksheet, which work very well, and the
previous image is removed and display a right image, but when I insert the
code into my existing worksheet over 100 MB size, which the image can be
displayed, but the previous image cannot be removed.
Do you have any suggestions?
Thank you very much for any suggestions
Eric
 
E

Eric

I have inserted some images into another cells, which is fixed and will not
be changed, because of the code myPic.Delete, which delete every image within
this worksheet. What if I would like to show 2 or 3 images and align each
image into different positions, could you please give me any suggestions on
where I can add the code for addition images?
Thank you very much for any suggestions
Eric
 
O

OssieMac

Hi again Eric,

I am not really sure what you don’t understand about inserting additional
pictures. You position them the same way that I have. I will try to explain
it all. Maybe you already know some and some you probably do not know.

Do you understand that Cells(10, "B") is the same as Range("B10").

The top position of the picture is the top position of cell B10
The left position of the picture is the left position of cell B10

The bottom of the picture is the bottom of cell B13 but we can’t find the
bottom position of a cell but we can find the top of the next cell B14 which
is the same as the bottom of B13.

Therefore we subtract the top of the cell B10 from the top of cell B14 to
get the height.

Similarly with the width. We subtract the left position of cell B10 from the
left position of cell D10 (left of D10 is same as right of C10).

You will note that I assigned the picture to an object variable when I
inserted it using the following code.

Set myPic = ActiveSheet.Pictures.Insert("C:\TempPic.JPG")

This is done so that we have a specific reference to the picture. With that
reference we can change its name from the default name of Picture X (where X
is a number.) You can do that with the following line of code.

myPic.Name = "PicAtB10"

You can use any name you like between the double quotes but don’t use names
like B10 on their own or it will become confused with cell references.

Now that the picture has a name, you can always refer to it by name. I have
amended your code to reference it by name when assigning to a variable for
deleting. That way you do not have to use Picture(1) which is the first
picture on the worksheet. When you delete Picture(1), the next picture on the
worksheet becomes Picture(1) but the name given to the picture will not
change. (Picture(1) is only an index number and is counted from the first
picture on the worksheet.)

Refer to the amended code below for info on how to insert additional pictures.

Previous images on the worksheet that you cannot remove will probably have
to be selected and deleted manually because you will not know their names to
reference them with code. (Note you could have pictures one on top of another
and deleting might appear not to work but just continue selecting and
deleting until image is gone.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myPic As Object
Dim dblTop As Double
Dim dblLeft As Double
Dim dblHeight As Double
Dim dblWidth As Double

If Target.Address = "$A$1" Then
On Error Resume Next

'Set myPic = ActiveSheet.Pictures(1) 'Delete this line

Set myPic = ActiveSheet.Shapes("PicAtB10")

On Error GoTo 0

If Not myPic Is Nothing Then myPic.Delete

'***********************************************
'Repeat the code betwen the asterisk lines for
'additional pictures
If Range("A1") = 1 Then
Set myPic = ActiveSheet.Pictures.Insert("C:\TempPic.JPG")
Else
Set myPic = ActiveSheet.Pictures.Insert("C:\TempPic2.JPG")
End If

myPic.Name = "PicAtB10"

'Set the variables for the picture
'top, left, height and width.
dblTop = Cells(10, "B").Top
dblLeft = Cells(10, "B").Left
dblHeight = Cells(14, "B").Top - Cells(10, "B").Top
dblWidth = Cells(10, "D").Left - Cells(10, "B").Left

With myPic
'next line is optional. See my previous post
'for what it does.
.ShapeRange.LockAspectRatio = msoFalse '/ msoTrue
.Top = dblTop
.Left = dblLeft
.Height = dblHeight
.Width = dblWidth
End With
'**********************************************

End If
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top