VBA to insert non-linked image into cell range while preserving aspect ratio

[Chris Chandler]

Hey all!

I have a button click macro designed to insert an image into a cell range. My old code worked fine, did what I needed it to do, and was quick. I've got it listed below.

Sub InsertImage()  On Error GoTo errh
Dim ws As Worksheet
Dim rng As Range
Dim myPath  As Variant
Set ws = ActiveSheet
Worksheets("Pages 3 & 4").Unprotect Password:="password"
Range("A34:E84").Select
myPath = Application.GetOpenFilename()
Set rng = ActiveCell
With ws.Pictures.Insert(myPath)


.Top = rng.Top + 10
.Left = 5
.Width = 400
.Locked = msoFalse
 


End With
Worksheets("Pages 3 & 4").Protect Password:="password"
Exit Sub
errh:
MsgBox "nothing found"
End Sub

The Width of the range is a bit more than 400, and the image resizes just fine, no worries. The problem I discovered was associated with the issue of linked images.

I used the sheet on another computer that did not have access to the location of the linked image and I received the error that I've seen is commonly recognized when trying to use linked images on non networked computers. So, now that I have discovered this bug, I researched and learned that I need to use the ActiveSheet.Shapes.AddPicture method to get the image to be actually embedded in the workbook. I understand the syntax of the method, but it's not preserving the aspect ratio, which I didn't expect it to, since it's a shape, not an image. However, I do need the aspect ratio preserved. In addition, I can't predict just what size image will be inserted. The cell range is meant to be a frame for an illustration, and the illustration dimensions are totally up to the user - the code would just change it so that the width doesn't extend past the width of the range, and then it scales accordingly.

This is In-process kludge code I have now. It inserts the image as a shape, though it does show the "nothing found" before the image is inserted. I think I'm correct in not needing to unlock the shape, and so have left it out of this code. I can re-size the inserted image to suit my needs, but I would much rather have the aspect ratio automatically re-scaled. I've also noted that if I need to insert another illustration, it seems merge with the first illustration. I need multiple images to not be merged together, even though the range is the same. That's why I need to be able to manually resize, if needed.

Sub InsertImage()
  On Error GoTo errh
Dim ws As Worksheet
Dim myPath  As Variant
Dim pic As Picture
Dim rng As Range
myPath = Application.GetOpenFilename()
Set ws = ActiveSheet
Set rng = Range("A34:E84")


Worksheets("Character Sheet Pages 3 & 4").Unprotect Password:="password"


rng.Select


Set pic = ws.Shapes.AddPicture(myPath, False, True, 5, rng.Top, rng.Width, rng.Height)




Worksheets("Character Sheet Pages 3 & 4").Protect Password:="password"
Exit Sub


errh:
MsgBox "nothing found"
End Sub

The only real constraints are the range width of 400, to have multiple, separate images, and to be able to manually edit or delete the image it if necessary. The Height is really just a place-holder, as it clearly skews whatever ratio I've got going on. In my previous code I just didn't define the image height and it scaled based on the width. I'm happy to start from scratch with this, but I'm really just stuck on this one.

To quickly restate my issue, I need to know how to use the Shapes.AddPicture method to embed an image in a set range, but preserve the aspect ratio of that image. I may need to have multiple images, depending on the user, and I need to easily edit or delete the image(s) once on the sheet.

Any assistance would be greatly appreciated. Thank you so much!

 

[Chris Chandler]

I do believe I've worked it out. I can define the width and height as "-1", and that maintains the original aspect ratio, and then I can assign the width and it resizes appropriately. A new image doesn't embed itself within an old image (honestly not sure why that was happening prior), and I can manipulate or delete the image if I need to.

Here is the code that worked for me, for anyone who might find it useful:

Sub InsertImage()  On Error GoTo errh


Dim myPath  As Variant
Dim lngLeft As Long
Dim lngTop As Long
Dim shpPic As Shape


Worksheets("Pages 3 & 4").Unprotect Password:="password"

Range("A34:E84").Select
myPath = Application.GetOpenFilename()
lngLeft = Columns("A:E").Left + 5
lngTop = Rows(34).Top + 5
Set shpPic = ActiveSheet.Shapes.AddPicture(myPath, False, True, lngLeft, lngTop, -1, -1)
With shpPic
    .Width = 400
    .Locked = False
End With

Worksheets("Pages 3 & 4").Protect Password:="password"


Exit Sub
errh:
MsgBox "nothing found"
End Sub

Thanks to anyone who was trying to puzzle this one out.