VBA 重なっているシェイプをグループ化するマクロ

今回の記事は重なりあうシェイプを自動判定してグループ化するマクロ。
といっても以前にクラスモジュールを使用してシェイプ同士が重なっているかどうかの判定までは作ってるので今回は手入れしてちゃんとグルーピング部分まで完成させたのでコードの紹介のみ。
thom.hateblo.jp

クラスモジュール

クラスモジュールを挿入し、オブジェクト名をShapeWrapperとしておく。
その名のとおり、Shapeを内包して今回のマクロ用に便利に扱う為のもの。

Private InnerShape As Shape

Public Property Get Name() As String
    Name = InnerShape.Name
End Property

Public Sub SetShape(s As Shape)
    Set InnerShape = s
End Sub

Public Property Get Top() As Single
    Top = InnerShape.Top
End Property

Public Property Get Left() As Single
    Left = InnerShape.Left
End Property

Public Property Get Bottom() As Single
    Bottom = InnerShape.Top + InnerShape.Height
End Property

Public Property Get Right() As Single
    Right = InnerShape.Left + InnerShape.Width
End Property

Public Property Get Nodes(Number As Integer) As Node
    Select Case Number
        Case 1
            Nodes.x = Me.Left
            Nodes.y = Me.Top
        Case 2
            Nodes.x = Me.Right
            Nodes.y = Me.Top
        Case 3
            Nodes.x = Me.Right
            Nodes.y = Me.Bottom
        Case 4
            Nodes.x = Me.Left
            Nodes.y = Me.Bottom
        Case Else
            Err.Raise 1000, , "1~4を指定してください。"
    End Select
End Property

Public Function IsOverlapped(SW As ShapeWrapper) As Boolean
    Dim i As Integer
    For i = 1 To 4 Step 1
        IsOverlapped = _
            (SW.Nodes(i).x > Me.Left And _
            SW.Nodes(i).x < Me.Right And _
            SW.Nodes(i).y > Me.Top And _
            SW.Nodes(i).y < Me.Bottom) _
            Or _
            (Me.Nodes(i).x > SW.Left And _
            Me.Nodes(i).x < SW.Right And _
            Me.Nodes(i).y > SW.Top And _
            Me.Nodes(i).y < SW.Bottom)
        If IsOverlapped Then Exit Function
    Next
End Function

肝となるのはIsOverlappedメソッド。これはShapeWrapper(つまり自己と同じ型のオブジェクト)を引数にとり、自分と重なっているかどうかを判定するメソッド。詳しくは冒頭で紹介した記事を参照。

標準モジュール

標準モジュールを挿入し、オブジェクト名を「Grouping」とする。ただまあ標準モジュールの命名は任意。

Public Type Node
    x As Single
    y As Single
End Type

Private Function WrappedShapes() As Collection
    'シェイプをShapeWrapperで包んでコレクションに追加
    Dim c As New Collection, s As Shape, SW1 As ShapeWrapper
    For Each s In ActiveSheet.Shapes
        Set SW1 = New ShapeWrapper
        SW1.SetShape s
        c.Add SW1, SW1.Name
    Next

    'コレクションの各シェイプ同士の重なり判定
    Dim c2 As Collection: Set c2 = New Collection
    
    Dim SW2 As ShapeWrapper
    For Each SW1 In c
        Dim arr() As Variant
        ReDim arr(0)
        arr(0) = SW1.Name
        c.Remove SW1.Name
        For Each SW2 In c
            If Not (SW1 Is SW2) Then
                If SW1.IsOverlapped(SW2) Then
                    ReDim Preserve arr(UBound(arr) + 1)
                    arr(UBound(arr)) = SW2.Name
                    c.Remove SW2.Name
                End If
            End If
        Next
        c2.Add arr
    Next
    Set WrappedShapes = c2
End Function

Private Sub RecUngroupShape(sh As Shape)
    Dim memberShape As Shape
    If sh.Type = msoGroup Then
        For Each memberShape In sh.Ungroup
            Call RecUngroupShape(memberShape)
        Next
    End If
End Sub

Public Sub GroupOverlappingShape()
    Dim SW() As Variant
    Dim c As Collection: Set c = WrappedShapes
    For i = 1 To c.Count
        SW = c(i)
        ActiveSheet.Shapes.Range(SW).Group
    Next
End Sub

Public Sub UngroupAllShapes()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        Call RecUngroupShape(sh)
    Next
End Sub

色々プロシージャがあるけれどマクロとして単体実行できるのはPublicになっている最後の2つのみ。
GroupOverlappingShapeを実行すると、アクティブなシート上で重なっているシェイプがすべてグループ化される。
UngroupAllShapesを実行するとアクティブなシート上のすべてのシェイプグループが解除される。

こんな感じで、赤枠と画像の重ね合わせはグループ化しておくと便利。
f:id:t-hom:20180602120054p:plain