ShapeRange对象行事古怪(ShapeRange Objects are acting wei

很抱歉，如果这是长。 我只好解释一切。

我有以下三个moduels：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

这里是我的表和地图截图：

地图＆表

接下来，我想它会很酷要经过形状区域阵列，并得到各对象的属性。此外，它使我得到的形状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.可以考虑删除，并添加形状

解决方案：A.由于当时没有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数组应该有相同数量的对象。直通。试错，我还发现，数组元素不会走动，并会停在原地，如果你移动你的对象。所以，你看到的，代码将比较我与shaperange数组中的元素创建的DemoTable内的元素。我可以验证这个作品，如果我开始四处移动的东西。它会成功地更新已移位形状的上和左属性。

问题/挑战/问题：然后我扩展的代码，因此，如果一个形状已被删除，它会识别。正如在我的代码看到，第四行中我的表（表索引= 4）应该是相同的（从而具有相同的形状ID）作为ShapeRange阵列中的第三元件。然而，如果第三形状被删除时，所述阵列得到收缩，这意味着新的（更新的automaically）shapeRange阵列中的第三元件被旧阵列中的第四元素。这是有用的，因为这样你可以用它来计算出，如果一个形状已被删除或没有。如果与TabeIndex相关联的ID = 4是相同的形状指数= 3，则这意味着，通过TableIndex = 4所描述的对象已被删除，并与形状指标形状准= 3应该是一样的一个由表引用指数= 5（下一个形状）。这就是为什么我添加形状指标=形状指标 - 1。

使故事很短，这个工作的时候，但是其他时候它是不准确的。昨天晚上，我删除了20点的形状和跑分。它告诉我，17点的对象被删除。我花几个小时看结果和调试代码，但一无所获。今天晚上，我删除15个对象后再次运行代码。这是我更新的表：

更新的演示表

那些红线意味着该行（特定形状）已被删除。在这种情况下，我删除了15周的形状，但它只能表明，只有12的形状已被删除。显然，这不是正确的。正如我刚才所说，昨晚发生的事情了。这不是一致的。为了证明这一点，我用了一个类似的代码作为我CreateDemMap子。基本上，它通过在工作表中的每个对象，使一个表像以前一样。如果一切都已经走了右边，这表应该是完全一样的我演示表（假设如果我删除这些红色行）。不是！

新表检查

新表我从ShapeRange阵列提取告诉我说，有70种形状的阵列中（15中删除这是正确的号码），但在我DemoTable，只有12行被突出显示为红色。这究竟是为什么？昨天晚上，我删除了一个特定形状具有特定形状的ID。通过这样做，我肯定是形状对象将不会在ShapeRange阵列。然而，当我调试，我意识到，情况并非如此。该对象是从我的屏幕上消失了，但它的形状ID（因而本身的形状）仍然在ShapeRange阵列。为什么VBA的Excel总是这样？有人能帮助我吗？

这真的很难理解所有的代码 - 但我认为你的问题是因为你太早结束你的循环。它一直运行直到ShapeNum这是你在你的表有形状的数量。当你删除一些形状，这个数字低于不检查你的表项，并在表中的最后一个条目的数量。