为什么我无法在 VBA 中更改形状的位置

Question

以下子例程将图片和文本框从源工作表导入到目标工作表。目标工作表位于活动工作簿中，但不一定位于 ActiveSheet 中。源工作表位于另一个（打开的）工作簿中。形状已成功复制，但更改其位置没有效果。目标工作表已受到保护，但取消保护没有效果。

Sub importShapes(target As Worksheet, source As Worksheet)
    Dim sourceShape As Shape
    For Each sourceShape In source.Shapes
        If sourceShape.Type = msoPicture Or sourceShape.Type = msoTextBox Then
            sourceShape.Copy
            target.Paste
           
            Dim targetShape As Shape
            Set targetShape = target.Shapes(target.Shapes.Count) ' the shape just added
            
            targetShape.top = sourceShape.top
            targetShape.left = sourceShape.left
        End If
    Next
End Sub

Answer 1

这是一种可能的方法：

Sub Tester()
    importShapes ThisWorkbook.Worksheets("sheet4"), ThisWorkbook.Worksheets("Sheet3")
End Sub


Sub importShapes(Target As Worksheet, source As Worksheet)
    Dim sourceShape As Shape, ids As String, shp As Shape, i As Long
    
    ids = "|"
    For Each shp In Target.Shapes 'collect all existing shape id's
        ids = ids & shp.id & "|"
    Next shp
    
    For Each sourceShape In source.Shapes
        If sourceShape.Type = msoPicture Or sourceShape.Type = msoTextBox Then
            sourceShape.Copy
            Target.Paste
            
            Dim targetShape As Shape
            Set targetShape = Target.Shapes(Target.Shapes.Count)
            
            For i = Target.Shapes.Count To 1 Step -1 'find the pasted shape
                Set shp = Target.Shapes(i)
                If InStr(ids, "|" & shp.id & "|") = 0 Then 'new id?
                    Set targetShape = shp    'newly-added
                    ids = ids & shp.id & "|" 'add to list
                End If
            Next i
            If Not targetShape Is Nothing Then 'got new shape?
                targetShape.top = sourceShape.top
                targetShape.Left = sourceShape.Left
            Else
                Debug.Print "no target shape"
            End If
        End If
    Next
End Sub