ShapeRange对象表现得很奇怪

Question

对不起，如果这很长。我必须解释一切。

我有以下三种模块： 1. CreateDemoMap 2. CreateDemoTable 3.更新

CreateDemoMap将遍历表格并获取位置（顶部和左侧），大小（宽度和长度），名称，旋转和形状标题，并将它们放在屏幕上。基本上，它将构建一个地图。这是我的代码的主要部分：

For i = 2 To endNum 'input the number manual for now

Top = Workbooks("Reference").Worksheets("Directory").Cells(i, 2)
Left = Workbooks("Reference").Worksheets("Directory").Cells(i, 3)
Width = Workbooks("Reference").Worksheets("Directory").Cells(i, 4)
Height = Workbooks("Reference").Worksheets("Directory").Cells(i, 5)
Name = Workbooks("Reference").Worksheets("Directory").Cells(i, 6)
Rotation = Workbooks("Reference").Worksheets("Directory").Cells(i, 7)
Title = Workbooks("Reference").Worksheets("Directory").Cells(i, 8)

Set sh = w.Shapes.AddShape(msoShapeRectangle, Left, Top, Width, Height)
    sh.Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Rotation = Rotation
    Selection.ShapeRange.Title = Title
    Selection.ShapeRange.Name = Name

Next i

以下是我的表格和地图的截图：

地图＆amp;表

接下来，我认为通过形状范围数组并获取每个对象的属性会很酷。此外，它使我能够获得形状ID。

Sub Test1()

Dim Top As Long
Dim Left As Long
Dim Width As Long
Dim Height As Long
Dim ID As String
Dim Name As String
Dim Rotation As String
Dim Title As String

Dim sh As Object
Dim endNum As Integer

CreateSheet ("DemoTable")

totalShape = 90
rnr = 2
IndexNum = 0

Worksheets("DemoMap").Activate

For Each shp In ActiveSheet.Shapes
    IndexNum = IndexNum + 1
    Worksheets("DemoTable").Cells(rnr, 1) = IndexNum
    Worksheets("DemoTable").Cells(rnr, 2) = shp.Top
    Worksheets("DemoTable").Cells(rnr, 3) = shp.Left
    Worksheets("DemoTable").Cells(rnr, 4) = shp.Width
    Worksheets("DemoTable").Cells(rnr, 5) = shp.Height
    Worksheets("DemoTable").Cells(rnr, 6) = shp.ID
    Worksheets("DemoTable").Cells(rnr, 7) = shp.Name
    Worksheets("DemoTable").Cells(rnr, 9) = shp.Rotation
    Worksheets("DemoTable").Cells(rnr, 10) = shp.Title
    Worksheets("DemoTable").Cells(rnr, 11) = shp.Type

rnr = rnr + 1
Next shp

End Sub

这就是它的样子：

形状表

目的： A.如果移动或旋转对象，则更新形状的顶部，左侧和旋转。 B.能够考虑删除和添加的形状

解决方案： 答：由于VBA中没有事件监听器，我决定让用户按需要移动对象，然后单击一个按钮来更新您之前看到的表。这是我的代码：

Sub UpdateShapes()

Dim Top As Long
Dim Left As Long
Dim Width As Long
Dim Height As Long
Dim ID As String
Dim Name As String
Dim Rotation As String
Dim Title As String
Dim sh As Object
Dim endNum As Integer
Dim Changes As Integer

Dim JSBChanges As Integer
Dim OneChanges As Integer
Dim TwoChanges As Integer
Dim ThreeChanges As Integer
Dim M1Changes As Integer
Dim M2Changes As Integer
Dim Deleted As Integer
Dim myDoc As Worksheet
Dim ShapeNum As Integer
Dim ShapeIndex As Integer

JSBChanges = 0
OneChanges = 0
TwoChanges = 0
ThreeChanges = 0
M1Changes = 0
M2Changes = 0
Deleted = 0



Set myDoc = Workbooks("Reference").Worksheets("DemoMap")
ShapeNum = myDoc.Shapes.Count
Debug.Print ("ShapeNum is: " & ShapeNum)

Workbooks("Reference").Worksheets("DemoMap").Activate

TableIndex = 2
ShapeIndex = 1

While (TableIndex <= (ShapeNum + 1))
    Changes = 0
If(Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 6) = myDoc.Shapes.Range(ShapeIndex).ID) Then
    If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 2) <> myDoc.Shapes.Range(ShapeIndex).Top) Then
        Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 2) = myDoc.Shapes.Range(ShapeIndex).Top
        Changes = Changes + 1
    End If
    If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 3) <> myDoc.Shapes.Range(ShapeIndex).Left) Then
        Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 3) = myDoc.Shapes.Range(ShapeIndex).Left
        Changes = Changes + 1
    End If
    If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 9) <> myDoc.Shapes.Range(ShapeIndex).Rotation) Then
        Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 9) = myDoc.Shapes.Range(ShapeIndex).Rotation
        Changes = Changes + 1
    End If

    If (Changes >= 1) Then

    With myDoc.Shapes.Range(ShapeIndex).Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
    End With


    Select Case (myDoc.Shapes.Range(ShapeIndex).Title)
        Case "JSB"
            JSBChanges = JSBChanges + 1
        Case "1"
            OneChanges = OneChanges + 1
        Case "2"
            TwoChanges = TwoChanges + 1
        Case "3"
            ThreeChanges = ThreeChanges + 1
        Case "M1"
            M1Changes = M1Changes + 1
        Case "M2"
            M2Changes = M2Changes + 1
    End Select

    End If
Else
    Deleted = Deleted + 1
    Workbooks("Reference").Worksheets("DemoTable").Rows(TableIndex).Interior.ColorIndex = 3
    Workbooks("Reference").Worksheets("DemoTable").Rows(TableIndex).Font.ColorIndex = 2
    ActiveWorkbook.Save
    ShapeIndex = ShapeIndex - 1

End If

    TableIndex = TableIndex + 1
    ShapeIndex = ShapeIndex + 1
    ShapeNum = myDoc.Shapes.Count
Wend

MsgBox ("JSBChanges: " & JSBChanges)
MsgBox ("OneChanges: " & OneChanges)
MsgBox ("TwoChanges: " & TwoChanges)
MsgBox ("ThreeChanges: " & ThreeChanges)
MsgBox ("M1Changes: " & M1Changes)
MsgBox ("M2Changes: " & M2Changes)
MsgBox ("Deleted: " & Deleted)

End Sub

假设没有添加或删除任何形状，这意味着shaperange数组应该具有相同数量的对象。直通。跟踪和错误，我还发现数组元素不会四处移动，如果移动物体，它们将保持静止。因此，如您所见，代码将比较刚刚创建的DemoTable中的元素与shaperange数组中的元素。如果我开始移动，我可以验证这是否有效。它将成功更新已移位的形状的Top和Left属性。

问题/质询/问题： 然后我扩展了代码，因此它将识别是否已删除某个形状。正如您在我的代码中看到的那样，我的表中的第四行（表索引= 4）应该与ShapeRange数组中的第三个元素相同（因此具有相同的形状ID）。但是，如果删除第三个形状，则数组会缩小，这意味着new（自动更新）shapeRange数组中的第三个元素是旧数组中的第四个元素。这很有用，因为您可以使用它来确定是否已删除形状。如果与TabeIndex = 4关联的ID与Shape Index = 3相同，则表示TableIndex = 4描述的对象已被删除，与Shape Index = 3关联的Shape应与Table引用的对象相同指数= 5（下一个形状）。这就是为什么，我添加了ShapeIndex = ShapeIndex - 1.

让故事简短，这有时会起作用，但有时候它不准确。昨晚我删除了20个形状并运行了子。它告诉我删除了17个对象。我花了几个小时查看结果并调试代码，但一无所获。今晚，我删除了15个对象后再次运行代码。这是我更新的表格：

更新了演示表

这些红线表示该行（特定形状）已被删除。在这种情况下，我删除了15个形状，但它只显示只删除了12个形状。显然这不对。正如我之前所说，它也发生在昨晚。它根本不一致。为了证明这一点，我使用了与我的CreateDemMap子类似的代码。基本上，它遍历工作表中的每个对象，并像以前一样制作表格。如果一切都会正确，那么这个表应该与我的演示表完全相同（假设我删除了那些红色行）。不是！

检查新表

我从ShapeRange数组中提取的新表告诉我，数组中有70个形状（15个被删除，这是正确的数字），但在我的DemoTable中，只有12行被突出显示为红色。为什么会这样？昨晚，我删除了具有特定形状ID的特定形状。通过这样做，我确信该形状对象不会在ShapeRange数组中。但是，当我调试时，我意识到事实并非如此。对象从我的屏幕上消失了，但它的形状ID（以及形状本身）仍然在ShapeRange数组中。为什么VBA Excel会像这样？有谁可以帮助我吗？

Answer 1

很难理解你的所有代码 - 但我认为你的问题是因为你过早地结束你的循环。它会一直运行到ShapeNum，这是您工作表中的形状数量。删除某些形状时，此数字低于表格中的条目数，并且不会检查表格中的最后一个条目。