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

Question

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

所以，说照片3我会创建箭头“aro3”和文本框“text3”。

然后我想分组它们并重命名该组“arotext”+我，所以在这个例子中“arotext3”。

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

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

其工作出色的子，但现在我想改变这种成一个函数，返回命名组，所以我尝试这样的事情：

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. 

这是造成差异。

通知你，我用Excel 2010和无法复制基于选择的原始代码片段（我得到一个错误做“Selection.Name =”，这给对象不支持属性。）

好，我能得到这个工作：

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

当然，像其他的片段，我建议，这个重新分配组的返回值，以便选择在Selection.Group和Selection.Name指的是不同的对象，这是我想想就是你想要的。

Answer 2

这是因为您正在手动存储新组作为对象，现在出现此错误。您可能无法对您创建的多个“AroTxt”&号码做任何事情。因为excel无法决定你的意思。

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

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

因此，为了解决您的问题，您必须在保存之前检查组是否已经存在。也许删除它，如果存在或添加到组中。

希望这有助于

Answer 3

编辑：因为它似乎总是去，错误开始雨后春笋般冒出来后，我点击提交。我会补充一点，但会回应@royka想知道你是否确实需要给同一个名称多个形状。

下面的代码似乎做你要找的东西（创建形状，给他们的名字，然后组）。在分组功能中，我留下了“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