0

我想创建一个宏来识别现有形状“图片 1”（增强的图元文件）的大小和位置，删除该形状，将图表“图表 3”从另一个工作簿复制到原始工作簿中作为增强的图元文件，并且尺寸/移动副本与原始形状的尺寸/位置相同。

我已将目标工作表声明为“wkst”，将源工作表声明为“源”。这一切都完美无缺，除了一件事：复制形状的第一个维度总是与原始形状略微偏离，无论我首先设置什么维度。在下面的代码中，形状的高度略有变化。

我添加了消息框，以便确保它们的值匹配，但MsgBox CurrentH（原始形状的高度）显示的值与MsgBox wkst.Shapes("Picture 1").Height（复制形状的高度）不同；它略有变化，即从 594 变为 572

任何帮助都会很棒，谢谢！

Dim CurrentW As Double
Dim CurrentH As Double
Dim CurrentT As Double
Dim CurrentL As Double

    CurrentH = wkst.Shapes("Picture 1").Height
    CurrentW = wkst.Shapes("Picture 1").Width
    CurrentT = wkst.Shapes("Picture 1").Top
    CurrentL = wkst.Shapes("Picture 1").Left

    MsgBox CurrentH
    MsgBox CurrentW
    MsgBox CurrentT
    MsgBox CurrentL

    Source.ChartObjects("Chart 3").Copy
    wkst.Shapes("Picture 1").Delete
    wkst.Activate
    wkst.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
    With ActiveWindow.Selection
            .Name = "Picture 1"
            .Height = CurrentH
            .Width = CurrentW
            .Left = CurrentL
            .Top = CurrentT
    End With

    MsgBox wkst.Shapes("Picture 1").Height
    MsgBox wkst.Shapes("Picture 1").Width
    MsgBox wkst.Shapes("Picture 1").Top
    MsgBox wkst.Shapes("Picture 1").Left
4

1 回答 1

0

在这种情况下，您需要添加更多参数来设置您复制的形状的尺寸。因此，而不是这部分代码：

With ActiveWindow.Selection
        .Name = "Picture 1"
        .Height = CurrentH
        .Width = CurrentW
        .Left = CurrentL
        .Top = CurrentT
End With

你需要添加这个：

With wkst.Shapes(wkst.Shapes.Count) '<-- the code set parameters of Shape therefore _
                                    this line need to be changed, too
        .Name = "Picture 1"
        .Left = CurrentL
        .Top = CurrentT
'new part -->
        .LockAspectRatio = msoFalse
    Dim Ratio As Double
        Ratio = CurrentH / CurrentW
        .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft
'<--new part
        .Width = CurrentW
        .Height = CurrentH
End With

参数的顺序很重要。代码经过试验和测试，对我来说运行良好。

于 2013-07-15T16:46:58.970 回答