我如何独立调整粘贴到工作表的图片的大小

Question

我如何独立调整在Worksheet_Activate上粘贴到工作表的多张图片的大小。

我可以调整粘贴到工作表的第一张图片的大小，但是不能单独调整后续图片的大小。我花了2周的时间尝试所有可以找到的方法，但是尝试将工作表上所有粘贴的图片调整为相同的大小，或者连续调整工作表上第一个图片的大小，而不是调整目标图片的大小。

以下代码将2张图片复制并粘贴到OUTPUT工作表中。第一张图片（TABLE）下的大小调整代码可以正确调整工作表上第一张图片的大小。但是，我还没有找到一种方法来独立调整其他粘贴图片（如“ CHART图片”）的大小。注意：为简便起见，我省略了在激活时删除图片的代码。

对此问题的解决方案将不胜感激？

'Copies TABLE Picture and Pastes on OUTPUT Worksheet
Worksheets("TABLE").Range("a1:O29").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("OUTPUT").Paste _
Destination:=Worksheets("OUTPUT").Range("B2")

'Resizes TABLE Picture on OUTPUT Worksheet
        Dim Shp As Shape
        Dim lWidth As Long, lHeight As Long

            Set Shp = ActiveWindow.Selection.ShapeRange(1)

            lHeight = Shp.Height
            lWidth = Shp.Width

            hp.Height = 3 * 72 * lHeight / lWidth
            Shp.Width = 4.75 * 72

'Copies CHART Picture and Pastes on OUTPUT Worksheet
Worksheets("CHART").Range("A1:j17").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Worksheets("OUTPUT").Paste _
Destination:=Worksheets("OUTPUT").Range("B18")


End Sub```

Answer 1

要更改工作表上的所有形状，可以使用For Each...Next循环。如果有人在执行代码时单击鼠标或在未选择任何形状的情况下执行代码单击，则可以使用You'd be better directly working with your sheet object而不是Selection来获得时髦的结果。

Sub TestShapeRange()

Dim Shp As Shape
Dim lWidth As Long, lHeight As Long

    For Each Shp In Sheet1.Shapes
        lHeight = Shp.Height
        lWidth = Shp.Width

        Shp.Height = 3 * 72 * lHeight / lWidth
        Shp.Width = 4.75 * 72
    Next Shp
End Sub

注意：这将更改指定工作表上ALL形状的大小，包括矩形，表单按钮等。

AutoShapeType属性返回一个MsoAutoShapeType枚举，对于粘贴到工作表中的图像（我使用复制/粘贴到工作表中的剪切工具图像进行了测试），它返回的是1，即msoShapeRectangle（矩形）。

您可以在循环中包含If...Then...Else语句，从而在工作表上没有其他矩形形状的情况下利用该优势。

If shp.AutoShapeType = 1 Then
    'Do your code 
    ...
Else
    'Do nothing
    'This will exit the If statement and go to the next iteration of your loop.
End If

请注意，由于我不经常使用Excel中的图像，因此可能会有其他人知道比此更整洁或更有效的解决方案，但是根据我的测试，此解决方案确实有效。