Copy and range of cells as a picture with a defined width Locked aspect ratio

Question

The macro shown successfully determines the name of worksheet and a named range of cells within that worksheet and then copies the range to another worksheet (Overview) in the same workbook as a picture whilst setting a defined width for the picture and locking it's aspect ratio.

Sub Copy_Dock_OptionsNew()  'Copy relevant Drive on Dock Options drawing and prices
                        'Use Dock Size to select correct input sheet

Dim dws, sws As Worksheet
Dim DrawingCode, swsName As String
Dim i As Integer

Application.ScreenUpdating = False

Set dws = Worksheets("Overview")

With dws

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Drawing Range Code
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    DrawingCode = "DOD" & Range("Dock_size") & "xOptions"

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Source Worksheet name (= DOD & Dock_Size value
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    swsName = "DOD" & dws.Range("Dock_Size")

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copy relevant dock summary drawing to Overview sheet
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Worksheets(swsName).Range(DrawingCode).CopyPicture xlScreen, xlPicture
    dws.Range("U13").Select
    dws.Paste
    Selection.ShapeRange.LockAspectRatio = True
    Selection.ShapeRange.Width = 420

End With
End Sub

This uses Select to define the paste area which I prefer not to use so have tried the following instead. This works but how do I fix the width and lock the aspect ratio?

Sub Copy_Dock_OptionsNew()  'Copy relevant Drive on Dock Options drawing and prices
                        'Use Dock Size to select correct input sheet

Dim dws, sws As Worksheet
Dim DrawingCode, swsName As String
Dim i As Integer

Application.ScreenUpdating = False

Set dws = Worksheets("Overview")

With dws

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Drawing Range Code
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    DrawingCode = "DOD" & Range("Dock_size") & "xOptions"

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Determine Source Worksheet name (= DOD & Dock_Size value
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    swsName = "DOD" & dws.Range("Dock_Size")

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Copy relevant dock summary drawing to Overview sheet
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Worksheets(swsName).Range(DrawingCode).CopyPicture _
       Appearance:=xlScreen, _
       Format:=xlPicture
    dws.Paste _
        Destination:=dws.Range("U13")
End With
End Sub

Domenic Domenic · Accepted Answer · 2020-04-04T16:40:00

Try the following code...

With dws
    .Paste Destination:=.Range("U13")
    With .Shapes(.Shapes.Count)
        .LockAspectRatio = msoTrue
        .Width = 420
    End With
End With

Although, it looks like the aspect ratio is already locked once the picture is pasted.

Copy and range of cells as a picture with a defined width Locked aspect ratio

1 Answers