复制和范围的单元格作为具有定义宽度的图片锁定纵横比

Question

显示的宏成功地确定了工作表的名称和该工作表中的命名单元格范围，然后将该范围复制到与图片相同的工作簿中的另一个工作表（概述），同时为图片设置定义的宽度并锁定它纵横比。

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

这使用 Select 来定义我不想使用的粘贴区域，因此尝试了以下方法。这行得通，但是如何固定宽度并锁定纵横比？

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

Answer 1

试试下面的代码...

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

不过，粘贴图片后，纵横比似乎已被锁定。