使用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