ShapeRange对象行为异常 [英] ShapeRange Objects are acting weirdly

问题描述

很抱歉，如果很长。我必须解释所有内容。

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

I have the following three moduels: 1. CreateDemoMap 2. CreateDemoTable 3. Update

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

The CreateDemoMap will go through a table and get the location (Top and Left), size (Width and Length), Name, Rotation and title of shapes and place them on the screen. Basically, it will build a map. This is the main part of my code:

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

这是我的桌子的屏幕截图以及地图：

Here is a screenshot of my table and the map:

接下来，我认为遍历形状范围数组并获取每个对象的属性会很酷。此外，它还使我可以获得形状ID。

Next, I thought it would be cool to go through the shape range array and get the properties of each objects. Also, it enabled me get the shape 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。能够解决删除和添加的形状

Objectives: A. update the Top, Left, and rotation of the shapes if the objects were moved or rotated. B. Be able to account for deleted and added shapes

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

Solutions: A. Since there wasn't an event listener in VBA, I decided to let the user move the objects however she want and then click a button that would update the table you saw earlier. Here is my code for this sub:

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数组中的元素。如果我开始四处移动，我可以验证此方法是否可行。它将成功更新已置换形状的顶部和左侧属性。

Let's assume no shape has been added or deleted, which means the shaperange array should have the same number of objects. Thru. trail and error, I also discovered that the array elements won't move around and will stay still if you move your objects around. So, as you see, the code will compare the elements inside the DemoTable I just created with the elements inside the shaperange array. I can verify that this works if I start move things around. It will successfully update the Top and Left properties of the shapes that have been displaced.

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

Problem/Challenge/Issue: Then I expanded the code, so it would identify if a shape has been deleted. As you see in my code, the fourth row in my table (Table Index = 4) should be the same (thus have the same shape ID) as the third element in the ShapeRange array. However if the third shape is deleted, the array get shrunk, which means the third element in the new (updated automaically) shapeRange array is the fourth element in the old array. This is useful, because then you can use this to figure out if a shape has been deleted or not. If the ID associated with TabeIndex = 4 is the same as Shape Index = 3, then that means that the object described by TableIndex = 4 has been deleted and the Shape associate with Shape Index = 3 should be the same as the one referenced by Table Index = 5 (the next shape). That's why, I added ShapeIndex = ShapeIndex - 1.

简而言之，有时可以奏效，但有时不正确。昨晚，我删除了20个形状并运行了子。它告诉我删除了17个对象。我花了几个小时来查找结果并调试代码，但一无所获。今天晚上，删除15个对象后，我再次运行代码。这是我更新的表：

Make the story short, this works sometimes, but the other times it's not accurate. Last night I deleted 20 shapes and ran the sub. It told me that 17 objects were deleted. I spend hours looking the results and debugging the code, but found nothing. This evening, I ran the code again after deleting 15 objects. Here is my updated table:

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

Those red lines mean that that row (particular shape) has been deleted. In this case, I deleted 15 shapes, but it only shows that only 12 shapes have been deleted. Obviously this not right. As I said earlier, it happened last night too. It's not consistent at all. To prove this, I used a similar code as my CreateDemMap sub. Basically, it goes through each objects in the worksheet and make a table just like before. If everything would've gone right, this table should be exactly the same as my Demo Table (assuming if I delete those red rows). It's NOT!

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

The new table I extracted from the ShapeRange array tells me that there are 70 shapes in the array (15 were deleted which is the correct number), but in my DemoTable, only 12 rows were highlighted as red. Why is this happening? Last night, I deleted a particular shape with a specific shape ID. By doing this, I was sure that that shape object would not be in the ShapeRange Array. However, when I was debugging, I realized that wasn't the case. The object was gone from my screen, but its shape ID (and consequently the shape itself) was still in the ShapeRange Array. Why is VBA Excel acting like this? Can someone help me please?

推荐答案

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

It's really hard to understand all your code - but I think your problem is because you're ending your loop too early. It runs until ShapeNum which is the number of shapes you have in your sheet. When you delete some shapes, this number is lower than the number of entries in your table and the last entries in the table are not checked.

这篇关于ShapeRange对象行为异常的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！