Agrupando y nombrando formas en Excel con vba

Question

En Excel vba, estoy creando dos formas en excel usando vba. Una flecha, que nombro "aro" + i, y un cuadro de texto, que nombro "texto" + i, donde i es un número que indica el número de una fotografía.

Por lo tanto, digamos que para la fotografía 3 voy a crear la flecha "aro3" y el cuadro de texto "text3".

Entonces quiero agruparlos y renombrar ese grupo "arotext" + i, por lo que "arotext3" en este caso.

Hasta ahora han estado haciendo la agrupación y cambiar el nombre de la siguiente manera:

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

que trabaja magníficamente en un submarino, pero ahora quiero cambiar esto en una función y volver al grupo llamado, así que probé algo como esto:

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

me encuentro con problemas cuando se crea un nuevo grupo que tiene el mismo nombre que uno que ya ha sido creado. Entonces, si creo un segundo "aro3" y "texto3" y luego trato de agruparlos y cambiar el nombre del grupo a "arotext3" me sale un error porque un grupo con el mismo nombre ya está presente.

Lo que no entiendo es que cuando hice esto usando el método que hace referencia a la selección, podría cambiar el nombre de cada grupo con el mismo nombre si quisiera y no obtendría un error. ¿Por qué funciona cuando se hace referencia al objeto Selección, pero falla al intentar usar un objeto asignado?

ACTUALIZACIÓN:

Dado que alguien le preguntó, el código que tengo hasta ahora es abajo. la flecha y el cuadro de texto son una flecha y un cuadro de texto que apuntan a una dirección definida arbitrariamente por el usuario que utiliza un formulario.

Esto crea una flecha en el ángulo correcto en la hoja de trabajo de destino y coloca un cuadro de texto con el número especificado (también a través del formulario) al final de la flecha, para que efectivamente forme una leyenda. Sé que hay llamadas, pero no hacen lo que quiero, así que tuve que hacer las mías.

Tengo que agrupar el cuadro de texto y la flecha porque 1) pertenecen juntos, 2) hago un seguimiento de los textos destacados que ya se han colocado utilizando el nombre del grupo como referencia, 3) el usuario tiene que colocar la llamada en el ubicación correcta en un mapa que está incrustado en la hoja de trabajo.

Hasta ahora he logrado convertir esto en una función haciendo que el valor devuelto sea un GroupObject. Pero esto todavía depende de Sheet.Shapes.range(). Select, que en mi opinión es una muy mala forma de hacerlo. Estoy buscando una forma que no dependa del objeto de selección.

Y me gustaría entender por qué esto funciona al usar la selección, pero falla al usar fuertes variables tipadas para contener los objetos.

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 devuelve un valor. Usted puede tratar de:

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

Sospecho que la selección actual se actualiza como si el siguiente en su trabajo anterior:

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

la que está causando la diferencia.

FYI, estoy usando Excel 2010 y no puede duplicar el fragmento de código original basado en Selección (me da un error hacer "Selection.Name =", lo que da objeto no soporta la propiedad.)

Ok, puedo conseguir que esto funcione:

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

por supuesto, al igual que el otro fragmento sugiero, esto vuelve a asignar el valor devuelto por el grupo, por lo que la selección en Selection.Group y Selection.Name se hace referencia a diferentes objetos, lo que me piensa que es lo que quieres

Answer 2

Es porque está almacenando los nuevos grupos como un objeto manualmente ahora que ha aparecido este error. Probablemente no pueda hacer nada con las múltiples instancias de "AroTxt" & Número que ha creado. Como excel no sería capaz de decidir a qué grupo te refieres.

Excel no debe permitir esto, pero no siempre advierte que esto ha sucedido, pero generará un error si intenta seleccionar un grupo que tiene un nombre duplicado.

Incluso si este no es el caso, no es una buena práctica tener nombres de variables duplicados. ¿No sería mejor agregar las Flechas y los cuadros de texto extra al grupo?

Para resolver su problema, deberá comprobar si el grupo ya existe antes de guardarlo. Tal vez eliminarlo si existe o agregar al grupo.

Esperanza esto ayuda

Answer 3

Editar: ya que siempre parece ir, el error, empezaron a aparecer después de que hace clic en Enviar. Voy a jugar un poco más, pero echo eco a @royka preguntándome si realmente necesitas darle el mismo nombre a múltiples formas.

El siguiente código parece hacer lo que estás buscando (crear las formas, darles nombres y luego agruparlas). En la función de agrupación, dejé el número "AroText" de la misma manera solo para ver si ocurría un error (no fue así). Parece que ambas formas tienen el mismo nombre, pero lo que las diferencia es su Shape.ID. Por lo que puedo decir, si dices ActiveSheet.Shapes("My Group").Select, seleccionará el elemento con ese nombre con la identificación más baja (en cuanto a por qué te permite nombrar dos cosas del mismo nombre, ninguna pista :)).

No es exactamente una respuesta a su pregunta de "por qué" (no pude replicar el error), pero con suerte le daré una forma de "cómo".

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