如何对形状数组进行分组

Question

我正在制作一个流程图，我想将整个流程图分组，以便用户稍后根据需要移动它。

我分别制作了一系列矩形和箭头，并相应地命名它们。 但是，我无法将它们全部分组在一起。

同一张纸中还会有更多这样的流程图。所以，我不想使用

thisSheet.Shapes

选项。

以下是我准备好的代码

Dim i As Integer
Dim outer_box As Shape
Dim shp(20) As Shape
Dim arw(20) As Shape
Dim shpgrp As Shape
Dim rg As Range
Dim height As Long


 
With ActiveSheet
    Set rg = .Range("B11")
End With

i = 1
height = 0
If process(i - 1) = vbNullString Then
    End
Else
    For i = 1 To 20
        If process(i - 1) = vbNullString Then 'Separate userform where process() array gets inputs
            Exit For
        Else
            Set shp(i) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1) 
            With shp(i)
                .Width = 150
                .TextFrame.HorizontalAlignment = xlHAlignLeft
                .TextFrame.VerticalAlignment = xlVAlignCenter
                .TextFrame.Characters.Text = i & ". " & process(i - 1) 'Separate userform where process() array gets inputs
                .Left = rg.Left + 5
                .Top = rg.Top + 10 + height + 20 * (i - 1)
                .Name = "shp" & i
            End With
            If Not i - 1 = 0 Then
                Set arw(i) = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100)
                With arw(i)
                    .Line.EndArrowheadStyle = msoArrowheadTriangle
                    .ConnectorFormat.BeginConnect shp(i - 1), 3
                    .ConnectorFormat.EndConnect shp(i), 1
                    .Name = "arw" & i
                End With
            End If
        End If
        height = height + shp(i).height
    Next i
    Set outer_box = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1)
    With outer_box
        .Top = rg.Top
        .Left = rg.Left
        .Width = 160
        .height = height + 20 * (i - 1)
        .ZOrder msoSendToBack
        .Name = "outer_box"
    End With
End If

Set shpgrp = ActiveSheet.Shapes.Range(Array("outer_box", "shp" & (i - 1), "arw" & (i - 1))).Group
shpgrp.Select
End Sub

我只能对最后的形状进行分组。如何对此处的形状和箭头数组进行分组？ 当 for 循环运行时，是否可以迭代地将形状和箭头添加到一个组中？ 谢谢。

Answer 1

• 收集所有形状的名称并使用

  Split

创建一个数组

微软文档：

分割功能

Option Explicit
Sub Demo()
    Dim i As Integer
    Dim outer_box As Shape
    Dim shp(20) As Shape
    Dim arw(20) As Shape
    Dim shpgrp As Shape
    Dim rg As Range
    Dim sShpList As String
    Dim height As Long
    With ActiveSheet
        Set rg = .Range("B11")
    End With
    i = 1
    height = 0
    If process(i - 1) = vbNullString Then
        End
    Else
        sShpList = "outer_box"
        For i = 1 To 20
            If process(i - 1) = vbNullString Then 'Separate userform where process() array gets inputs
                Exit For
            Else
                Set shp(i) = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1)
                With shp(i)
                    .Width = 150
                    .TextFrame.HorizontalAlignment = xlHAlignLeft
                    .TextFrame.VerticalAlignment = xlVAlignCenter
                    .TextFrame.Characters.Text = i & ". " & process(i - 1) 'Separate userform where process() array gets inputs
                    .Left = rg.Left + 5
                    .Top = rg.Top + 10 + height + 20 * (i - 1)
                    .Name = "shp" & i
                    sShpList = sShpList & "|" & "shp" & i
                End With
                If Not i - 1 = 0 Then
                    Set arw(i) = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 100, 100, 100, 100)
                    With arw(i)
                        .Line.EndArrowheadStyle = msoArrowheadTriangle
                        .ConnectorFormat.BeginConnect shp(i - 1), 3
                        .ConnectorFormat.EndConnect shp(i), 1
                        .Name = "arw" & i
                        sShpList = sShpList & "|" & "arw" & i
                    End With
                End If
            End If
            height = height + shp(i).height
        Next i
        Set outer_box = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1, 1, 1, 1)
        With outer_box
            .Top = rg.Top
            .Left = rg.Left
            .Width = 160
            .height = height + 20 * (i - 1)
            .ZOrder msoSendToBack
            .Name = "outer_box"
        End With
    End If
    Set shpgrp = ActiveSheet.Shapes.Range(Split(sShpList, "|")).Group
    shpgrp.Select
End Sub