CODEWITHSUNDEEP
vbaimageresizeembedaspect-ratio
Gareth
Gareth

Reputation: 21

Embed and resize image in Excel maintaining aspect ratio

I'm trying to write a VBA macro for Excel to embed and resize an image maintaining aspect ratio. I'd like to embed rather than link so Excel file can be shared between computers.

I have 2 pieces of code.

1st will embed an image (SaveWithDocument), position the image and change the height (but not maintain aspect ratio). 

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoCTrue, _
        Left:=1050, _
        Top:=35, _
        Width:=-1, _
        Height:=150)

Else
            MsgBox ("No picture inserted")
        End If
    End With

End Sub

2nd will link an image, poistion the image and change the height (maintaining aspect ration). This option will not embed image.

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

With ActiveSheet.Pictures.Insert(.SelectedItems(1))
    .ShapeRange.lockaspectratio = msoTrue
    .Left = 1050
    .Top = 35
    .Height = 150
End With

Else
            MsgBox ("No picture inserted")
        End If
    End With

End Sub

Whilst both pieces of code work well separately, I am unable to combine them. I understand "SaveWithDocument" doesn't work with "Pictures.Insert" and "LockAspectRatio" doesn't work with "Shapes.AddPicture"?

Can anyone offer some guidance?

Many thanks.

Upvotes: 1

Views: 2153

Answers (2)

Gareth
Gareth

Reputation: 21

Seems to be solved now, and works well. Many thanks for the help.

Sub Button7_Click()

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then

        Dim pic As Shape
        Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
           LinkToFile:=msoFalse, _
         SaveWithDocument:=msoCTrue, _
         Left:=1050, _
         Top:=35, _
         Width:=-1, _
         Height:=-1)
      pic.lockaspectratio = msoTrue
      pic.Height = 150

      Else
        MsgBox ("No picture inserted")
       End If

End With

End Sub

Upvotes: 1

Red
Red

Reputation: 3267

If you do it in 2 steps I think it will work, i.e., insert the image in original size and set LockAspectRatio, then resize it.

Set pic = ActiveSheet.Shapes.AddPicture(.SelectedItems(1), _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoCTrue, _
    Left:=1050, _
    Top:=35, _
    Width:=-1, _
    Height:=-1).LockAspectRatio = msoTrue
pic.Height = 150

Upvotes: 0

Related Questions