使用 vba 在 Excel 中对形状进行分组和命名

Grouping and naming shapes in Excel with vba

提问by yu_ominae

In Excel vba, I am creating two shapes in excel using vba. An arrow, which I name "aro" + i, and a textbox, which I name "text" + i, where i is a number indicating the number of a photograph.

在 Excel vba 中，我使用 vba 在 excel 中创建两个形状。一个箭头，我命名为“aro”+ i，以及一个文本框，我命名为“text”+ i，其中 i 是表示照片编号的数字。

So, say for photograph 3 I will creat arrow "aro3" and textbox "text3".

因此，对于照片 3，我将创建箭头“aro3”和文本框“text3”。

I then want to group them and rename that group "arotext" + i, so "arotext3" in this instance.

然后我想对它们进行分组并将该组重命名为“arotext”+ i，在本例中为“arotext3”。

So far I have been doing the grouping and renaming like this:

到目前为止，我一直在进行这样的分组和重命名：

targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name)).Select
Selection.group
Selection.Name = "AroTxt" & Number

which works splendidly in a sub, but now I want to change this into a function and return the named group, so I tried something like this:

它在 sub 中工作得很好，但现在我想把它改成一个函数并返回命名组，所以我尝试了这样的事情：

Dim arrowBoxGroup as Object
set arrowBoxGroup = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
arrowBoxGroup.group
arrowBoxGroup.Name = "AroTxt" & Number

I run into problems when I create a new group which has the same name as one which has already been created. So, if I create a second "aro3" and "text3" and then try to group them and rename the group to "arotext3" I get an error because a group with the same name is already present.

当我创建一个与已经创建的组同名的新组时，我遇到了问题。因此，如果我创建第二个“aro3”和“text3”，然后尝试将它们分组并将该组重命名为“arotext3”，则会出现错误，因为已存在同名的组。

The thing I don't understand is that when I did this using the method referring to the selection, I could rename every group with the same name if I wanted and wouldn't get an error. Why does it work when referring to the Selection object, but fails when trying to use an assigned object?

我不明白的是，当我使用引用选择的方法执行此操作时，如果需要，我可以使用相同的名称重命名每个组，并且不会出错。为什么它在引用 Selection 对象时有效，但在尝试使用分配的对象时失败？

UPDATE:

更新：

Since somebody asked, the code I have so far is below. arrow and textbox are an arrow and a textbox which point into a direction arbitrarily defined by the user using a form.

既然有人问了，我到目前为止的代码如下。箭头和文本框是指向用户使用表单任意定义的方向的箭头和文本框。

This then creates an arrow at the correct angle on the target worksheet and places a textbox with the specified number (also through the form) at the end of the arrow, so that it effectively forms a callout. I know that there are callouts, but they don't do what I want so I had to make my own.

然后在目标工作表上以正确的角度创建一个箭头，并在箭头的末尾放置一个具有指定编号（也通过表单）的文本框，以便有效地形成标注。我知道有标注，但它们不符合我的要求，所以我必须自己制作。

I have to group the textbox and arrow because 1) they belong together, 2) I keep track of which callouts have already been placed using the group's name as a reference, 3) the user has to place the callout in the right location on a map which is embedded in the worksheet.

我必须将文本框和箭头分组，因为 1) 它们属于一起，2) 我使用组的名称作为参考跟踪已经放置了哪些标注，3) 用户必须将标注放置在正确的位置嵌入在工作表中的地图。

So far I have managed to make this into a function by making the return value a GroupObject. But this still relies on Sheet.Shapes.range().Select, which in my opinion is a very bad way of doing this. I am looking for a way which does not rely on the selection object.

到目前为止，我已经通过将返回值设置为 GroupObject 来将它变成一个函数。但这仍然依赖于 Sheet.Shapes.range().Select，在我看来这是一种非常糟糕的方式。我正在寻找一种不依赖于选择对象的方法。

And I would like to understand why this works when using selection, but fails when using strong typed variables to hold the objects.

我想了解为什么这在使用选择时有效，但在使用强类型变量来保存对象时失败。

    Public Function MakeArrow(ByVal No As Integer, ByVal angle As Double, ByVal size As ArrowSize, ByVal ArrowX As Double, ByVal ArrowY As Double, ByVal TargetInternalAngle As Double, ByRef targetSheet As Worksheet) As GroupObject

    Dim Number As String
    Dim fontSize As Integer
    Dim textboxwidth As Integer
    Dim textboxheight As Integer
    Dim arrowScale As Double
    Dim X1 As Double
    Dim Y1 As Double
    Dim X2 As Double
    Dim Y2 As Double
    Dim xBox As Double
    Dim yBox As Double
    Dim testRange As Range
    Dim arrow As Shape
    Dim textBox As Shape
'    Dim arrowTextbox As ShapeRange
'    Dim arrowTextboxGroup As Variant

    Select Case size
        Case ArrowSize.normal
            fontSize = fontSizeNormal
            arrowScale = arrowScaleNormal
        Case ArrowSize.small
            fontSize = fontSizeSmall
            arrowScale = arrowScaleSmall
        Case ArrowSize.smaller
            fontSize = fontSizeSmaller
            arrowScale = arrowScaleSmaller
    End Select
    arrowScale = baseArrowLength * arrowScale

    'Estimate required text box width
    Number = Trim(CStr(No))
    Set testRange = shtTextWidth.Range("A1")
    testRange.value = Number
    testRange.Font.Name = "ＭＳ Ｐ明朝"
    testRange.Font.size = fontSize
    shtTextWidth.Columns(testRange.Column).EntireColumn.AutoFit
    shtTextWidth.Columns(testRange.row).EntireRow.AutoFit
    textboxwidth = testRange.Width * 0.8
    textboxheight = testRange.Height * 0.9
    testRange.Clear

    'Make arrow
    X1 = ArrowX
    Y1 = ArrowY
    X2 = X1 + arrowScale * Cos(angle)
    Y2 = Y1 - arrowScale * Sin(angle)
    Set arrow = AddArrow(X1, Y1, X2, Y2, Number, targetSheet)

    'Make text box
    Set textBox = Addtextbox(angle, Number, fontSize, X2, Y2, textboxwidth, textboxheight, TargetInternalAngle, targetSheet)

    'Group arrow and test box
    targetSheet.shapes.Range(Array(arrow.Name, textBox.Name)).group.Select
    Selection.Name = "AroTxt" & Number

    Set MakeArrow = Selection

'    Set arrowTextbox = targetSheet.shapes.Range(Array(arrow.Name, textBox.Name))
'    Set arrowTextboxGroup = arrowTextbox.group
'    arrowTextboxGroup.Name = "AroTxt" & Number
'
'    Set MakeArrow = arrowTextboxGroup

End Function

Private Function AddArrow(ByVal StartX As Double, ByVal StartY As Double, ByVal EndX As Double, ByVal EndY As Double, ByVal Number As String, ByRef targetSheet As Worksheet) As Shape

    Set AddArrow = targetSheet.shapes.AddLine(StartX, StartY, EndX, EndY)
    With AddArrow
        .Name = "Aro" & Number
        With .Line
            .BeginArrowheadStyle = msoArrowheadTriangle
            .BeginArrowheadLength = msoArrowheadLengthMedium
            .BeginArrowheadWidth = msoArrowheadWidthMedium
            .ForeColor.RGB = RGB(0, 0, 255)
        End With
    End With

End Function

Private Function Addtextbox(ByVal angle As Double, ByVal Number As String, ByVal fontSize As Integer, ByVal arrowEndX As Double, ByVal arrowEndY As Double, ByVal Width As Integer, ByVal Height As Integer, ByVal LimitAngle As Double, ByRef targetSheet As Worksheet) As Shape

    Dim xBox, yBox As Integer
    Dim PI As Double
    Dim horizontalAlignment As eTextBoxHorizontalAlignment
    Dim verticalAlignment As eTextBoxVerticalAlignment

    PI = 4 * Atn(1)

    If LimitAngle = 0 Then
        LimitAngle = PI / 4
    End If

    Select Case angle
        'Right
        Case 0 To LimitAngle, 2 * PI - LimitAngle To 2 * PI
            xBox = arrowEndX
            yBox = arrowEndY - Height / 2
            horizontalAlignment = eTextBoxHorizontalAlignment.left
            verticalAlignment = eTextBoxVerticalAlignment.Center
        'Top
        Case LimitAngle To PI - LimitAngle
            xBox = arrowEndX - Width / 2
            yBox = arrowEndY - Height
            horizontalAlignment = eTextBoxHorizontalAlignment.Middle
            verticalAlignment = eTextBoxVerticalAlignment.Bottom
        'Left
        Case PI - LimitAngle To PI + LimitAngle
            xBox = arrowEndX - Width
            yBox = arrowEndY - Height / 2
            horizontalAlignment = eTextBoxHorizontalAlignment.Right
            verticalAlignment = eTextBoxVerticalAlignment.Center
        'Bottom
        Case PI + LimitAngle To 2 * PI - LimitAngle
            xBox = arrowEndX - Width / 2
            yBox = arrowEndY
            horizontalAlignment = eTextBoxHorizontalAlignment.Middle
            verticalAlignment = eTextBoxVerticalAlignment.top
    End Select

    Set Addtextbox = targetSheet.shapes.Addtextbox(msoTextOrientationHorizontal, xBox, yBox, Width, Height)
    With Addtextbox
        .Name = "Txt" & Number
        With .TextFrame
            .AutoMargins = False
            .AutoSize = False
            .MarginLeft = 0#
            .MarginRight = 0#
            .MarginTop = 0#
            .MarginBottom = 0#
            Select Case verticalAlignment
                Case eTextBoxVerticalAlignment.Bottom
                    .verticalAlignment = xlVAlignBottom
                Case eTextBoxVerticalAlignment.Center
                    .verticalAlignment = xlVAlignCenter
                Case eTextBoxVerticalAlignment.top
                    .verticalAlignment = xlVAlignTop
            End Select
            Select Case horizontalAlignment
                Case eTextBoxHorizontalAlignment.left
                    .horizontalAlignment = xlHAlignLeft
                Case eTextBoxHorizontalAlignment.Middle
                    .horizontalAlignment = xlHAlignCenter
                Case eTextBoxHorizontalAlignment.Right
                    .horizontalAlignment = xlHAlignRight
            End Select
            With .Characters
                .Text = Number
                With .Font
                    .Name = "ＭＳ Ｐ明朝"
                    .FontStyle = "標準"
                    .size = fontSize
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Underline = xlUnderlineStyleNone
                    .ColorIndex = xlAutomatic
                End With
            End With
        End With
        .Fill.Visible = msoFalse
        .Fill.Solid
        .Fill.Transparency = 1#
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .style = msoLineSingle
            .Transparency = 0#
            .Visible = msoFalse
        End With
    End With


End Function

回答by Erik Eidt

Range.Group returns a value. You might try:

Range.Group 返回一个值。你可以试试：

Set arrowBoxRange = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
Set arrowBoxGroup = arrowBoxRange.Group
arrowBoxGroup.Name = "AroTxt" & Number

I suspect that the current Selection gets updated as if the following in your earlier work:

我怀疑当前的选择会更新，就像您早期工作中的以下内容一样：

Set Selection = Selection.Group  'it's as if this is done for you when you create the group.

which is causing the difference.

这导致了差异。

FYI, I'm using Excel 2010 and cannot duplicate the original code snippet based on Selection (I get an error doing "Selection.Name = ", which gives object does not support property.)

仅供参考，我使用的是 Excel 2010，无法复制基于选择的原始代码片段（我在执行“Selection.Name =”时出错，这使对象不支持属性。）

Ok, I can get this to work:

好的，我可以让它工作：

Selection.Group.Select
Selection.Name = "AroTxt"

Of course, like the other snippet I suggest, this reassigns the group's return value, so that Selection in Selection.Group and Selection.Name are referring to different objects, which I think is what you want.

当然，就像我建议的另一个片段一样，这会重新分配组的返回值，以便 Selection.Group 和 Selection.Name 中的 Selection 指的是不同的对象，我认为这就是您想要的。

回答by royka

It is because you are storing the new groups as an object manually now that this error has appeared. You probably are not able to do anything with the multiple instances of "AroTxt" & Numberthat you have created. As excel wouldn't be able to decide which group you mean.

这是因为出现此错误是因为您正在手动将新组存储为对象。您可能无法对您创建的多个“AroTxt”和 Number实例执行任何操作。由于 excel 无法确定您指的是哪个组。

Excel shouldn't allow this but it doesn't always warn that this has happened but will error if you try to select a group that has a duplicate name.

Excel 不应允许这样做，但它并不总是警告发生了这种情况，但如果您尝试选择具有重复名称的组，则会出错。

Even if this isn't the case, it isn't good practice to have duplicate variable names. Would it not be better to add the extra Arrow's and textBox's to the group?

即使情况并非如此，使用重复的变量名称也不是一个好习惯。将额外的箭头和文本框添加到组中不是更好吗？

So to solve your problem you will have to check to see if the group already exists before you save it. Maybe delete it if exists or add to the group.

因此，要解决您的问题，您必须在保存之前检查该组是否已存在。如果存在，可以将其删除或添加到组中。

Hope this helps

希望这可以帮助

回答by RocketDonkey

Edit:As it always seems to go, the error started popping up after I clicked submit. I'll tinker around a bit more, but will echo @royka in wondering if you really do need to give the same name to multiple shapes.

编辑：似乎总是如此，单击提交后错误开始弹出。我会多做一些修改，但会回应@royka 想知道您是否真的需要为多个形状赋予相同的名称。

The below code seems to do what you're looking for (create the shapes, give them names and then group). In the grouping function, I left the "AroText" number the same just to see if an error would happen (it did not). It seems that both shapes have the same name, but what differentiates them is their Shape.ID. From what I can tell, if you say ActiveSheet.Shapes("My Group").Select, it will select the element with that name with the lowest ID (as to why it lets you name two things the same name, no clue :) ).

下面的代码似乎做你正在寻找的东西（创建形状，给它们命名然后分组）。在分组功能中，我将“AroText”编号保持不变，只是为了查看是否会发生错误（它没有发生）。似乎这两个形状具有相同的名称，但它们的区别在于它们的Shape.ID. 据我所知，如果您说ActiveSheet.Shapes("My Group").Select，它将选择具有最低 ID 的名称的元素（至于为什么它允许您将两个事物命名为相同的名称，不知道 :) ）。

It isn't quite an answer to your question of "why" (I wasn't able to replicate the error), but this will hopefully give you one way "how".

这不是您的“为什么”问题的答案（我无法复制错误），但这有望为您提供一种“如何”的方法。

Sub SOTest()

Dim Arrow As Shape
Dim TextBox As Shape
Dim i as Integer
Dim Grouper As Variant
Dim ws As Worksheet

Set ws = ActiveSheet

' Make two shapes and group, naming the group the same in both cases
For i = 1 To 2
  ' Create arrow with name "Aro" & i
  Set Arrow = ws.Shapes.AddShape(msoShapeRightArrow, 10, 50, 30, 30)
  Arrow.Name = "Aro" & i

  ' Create text box with name "Text" & i
  Set TextBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 40, 40)
  TextBox.Name = "Text" & i

  ' Use a group function to rename the shapes
  Set Grouper = CreateGroup(ws, Arrow, TextBox, i)

  ' See the identical names but differing IDs
  Debug.Print "Name: " & Grouper.Name & " | ID: " & Grouper.ID
Next

End Sub


Function CreateGroup(ws As Worksheet, Arrow As Shape, TextBox As Shape, Number As Integer) As Variant

Dim arrowBoxGroup As Variant

' Group the provided shapes and change the name
Set arrowBoxGroup = ws.Shapes.Range(Array(Arrow.Name, TextBox.Name)).Group
arrowBoxGroup.Name = "AroTxt" & Number

' Return the grouped object
Set CreateGroup = arrowBoxGroup

End Function