VBA Excel 2010 - Embedding Pictures and Resizing - excel

Question

I've been lurking for a while and found it very helpful, so thanks for the help already!
I'm trying to write a macro to embed images into a worksheet from individual files and resize them, whilst keeping the full resolution of the image intact should it need to be enlarged again. First of all I tried:
ActiveSheet.Pictures.Insert(imageName).Select
With Selection.ShapeRange
.Height = 100
.Width = 100
End With
This essentially inserted a link to the picture and if the image file was removed or the excel file moved to another computer, the link would be broken. Next I tried:
ActiveSheet.Shapes.AddPicture Filename:=imageName, _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Width:=100, _
Height:=100
This code also works, but the image is resized to 100 * 100 pixels before insertion, so the original file resolution is lost.
Is there any way to insert image files and then scale them down in size, so that the original resolution is retained?

Answer 1

You first load and position the picture in its original size, and in a second step resize it as desired. You only specify EITHER width or heigth to retain the aspect ratio.
Sub Test()
Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single
' position in Pixel relative to top/left of sheet
MyTop = 50
MyLeft = 50
' alternatively position to the top/left of [range] C3
MyTop = [C3].Top
MyLeft = [C3].Left
' alternatively position to top/left of actual scrolled position
MyTop = Cells(Windows(1).ScrollRow, Windows(1).ScrollColumn).Top
MyLeft = Cells(Windows(1).ScrollRow, Windows(1).ScrollColumn).Left
Set MySht = ActiveSheet
Set MyPic = MySht.Shapes.AddPicture("C:\Users\MikeD\Desktop\Untitled.png", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
' ^^^ LinkTo SaveWith -1 = keep size
' now resize pic
MyPic.Height = 100
End Sub
... and try to avoid .Select ... Dim the objects you need and use them.