CODEWITHSUNDEEP
excelvba
awenborn
awenborn

Reputation: 417

VBA Excel 2010 - Embedding Pictures and Resizing

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?

Upvotes: 7

Views: 40969

Answers (1)

MikeD
MikeD

Reputation: 8941

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.

Upvotes: 17

Related Questions