How to stretch image cover specific cell?
 

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

How to stretch image cover specific cell?
 

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

--
Regards,

OssieMac

How to stretch image cover specific cell?
 

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

--
Regards,

OssieMac

How to stretch image cover specific cell?
 

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

"OssieMac" wrote:

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

--
Regards,

OssieMac

How to stretch image cover specific cell?
 

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

"OssieMac" wrote:

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

--
Regards,

OssieMac