Question

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

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

我添加了消息框，因此我可以确保它们的值匹配，但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

Answer 1

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

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

参数的顺序很重要。代码是 经过试用和验证 ，它对我来说很好。

分配形状尺寸时出错

1 个答案: