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

Question

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

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

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

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

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

它在sub中工作得很好，但现在我想将它更改为一个函数并返回命名组，所以我尝试了类似这样的操作：

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

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

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

更新：

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

这将在目标工作表上以正确的角度创建一个箭头，并在箭头的末尾放置一个具有指定数字(也通过表单)的文本框，以便它有效地形成一个标注。我知道有标注，但它们不能满足我的要求，所以我不得不自己制作。

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

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

我想要理解为什么在使用选择时这是可行的，但在使用强类型变量来保存对象时却失败了。

    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

Answer 1

Range.Group返回值。您可以尝试：

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

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

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

这就是造成这种差异的原因。

仅供参考，我使用的是Excel2010，无法复制基于选择的原始代码片段(执行"Selection.Name =“操作时出现错误，这给出了object不支持属性)。

好的，我可以让它工作：

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

当然，像我建议的其他代码片段一样，这将重新分配组的返回值，以便Selection.Group和Selection.Name中的选择引用不同的对象，我认为这正是您想要的。

Answer 2

这是因为您正在手动将新组存储为对象，因为出现了此错误。您可能无法对您创建的"AroTxt“& Number的多个实例执行任何操作。因为excel不能决定你指的是哪一组。

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

即使不是这样，使用重复的变量名也不是一种好的做法。将额外的箭头和文本框添加到组中不是更好吗？

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

希望这能有所帮助

Answer 3

编辑：就像往常一样，在我点击提交后错误开始弹出。我会再修修补补一些，但我会回应@royka，想知道你是否真的需要为多个形状提供相同的名称。

下面的代码似乎做了你想要做的(创建形状，给它们命名，然后分组)。在grouping函数中，我将"AroText“数字保持不变，只是为了看看是否会发生错误(它没有)。这两个形状似乎具有相同的名称，但区分它们的是它们的Shape.ID。据我所知，如果您说ActiveSheet.Shapes("My Group").Select，它将选择具有最低ID的元素(至于为什么它允许您将两个事物命名为相同的名称，没有线索:)。

它不能完全回答你的“为什么”的问题(我不能复制错误)，但希望这能给你一种“如何”的方法。

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