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

クラスモジュール

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

Private InnerShape As Shape

PublicPropertyGetName()AsStringName= InnerShape.NameEndPropertyPublicSub SetShape(s As Shape)Set InnerShape = s
EndSubPublicPropertyGet Top()AsSingle
    Top = InnerShape.Top
EndPropertyPublicPropertyGetLeft()AsSingleLeft= InnerShape.LeftEndPropertyPublicPropertyGet Bottom()AsSingle
    Bottom = InnerShape.Top + InnerShape.Height
EndPropertyPublicPropertyGetRight()AsSingleRight= InnerShape.Left+ InnerShape.WidthEndPropertyPublicPropertyGet Nodes(Number AsInteger)As Node
    SelectCase Number
        Case1
            Nodes.x =Me.Left
            Nodes.y =Me.Top
        Case2
            Nodes.x =Me.Right
            Nodes.y =Me.Top
        Case3
            Nodes.x =Me.Right
            Nodes.y =Me.Bottom
        Case4
            Nodes.x =Me.Left
            Nodes.y =Me.Bottom
        CaseElse
            Err.Raise1000,,"1~4を指定してください。"EndSelectEndPropertyPublicFunction IsOverlapped(SW As ShapeWrapper)AsBooleanDim i AsIntegerFor i =1To4Step1
        IsOverlapped = _(SW.Nodes(i).x >Me.LeftAnd _
            SW.Nodes(i).x <Me.RightAnd _
            SW.Nodes(i).y >Me.Top And _
            SW.Nodes(i).y <Me.Bottom) _Or _(Me.Nodes(i).x > SW.LeftAnd _Me.Nodes(i).x < SW.RightAnd _Me.Nodes(i).y > SW.Top And _Me.Nodes(i).y < SW.Bottom)If IsOverlapped ThenExitFunctionNextEndFunction

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

標準モジュール

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

PublicType Node
    x AsSingle
    y AsSingleEndTypePrivateFunction WrappedShapes()As Collection
   'シェイプをShapeWrapperで包んでコレクションに追加Dim c AsNew Collection, s As Shape, SW1 As ShapeWrapper
    ForEach s In ActiveSheet.Shapes
        Set SW1 =New ShapeWrapper
        SW1.SetShape s
        c.Add SW1, SW1.NameNext'コレクションの各シェイプ同士の重なり判定Dim c2 As Collection: Set c2 =New Collection
    
    Dim SW2 As ShapeWrapper
    ForEach SW1 In c
        Dim arr()AsVariantReDim arr(0)
        arr(0)= SW1.Name
        c.Remove SW1.NameForEach SW2 In c
            IfNot(SW1 Is SW2)ThenIf SW1.IsOverlapped(SW2)ThenReDimPreserve arr(UBound(arr)+1)
                    arr(UBound(arr))= SW2.Name
                    c.Remove SW2.NameEndIfEndIfNext
        c2.Add arr
    NextSet WrappedShapes = c2
EndFunctionPrivateSub RecUngroupShape(sh As Shape)Dim memberShape As Shape
    If sh.Type= msoGroup ThenForEach memberShape In sh.Ungroup
            Call RecUngroupShape(memberShape)NextEndIfEndSubPublicSub GroupOverlappingShape()Dim SW()AsVariantDim c As Collection: Set c = WrappedShapes
    For i =1To c.Count
        SW = c(i)
        ActiveSheet.Shapes.Range(SW).Group
    NextEndSubPublicSub UngroupAllShapes()Dim sh As Shape
    ForEach sh In ActiveSheet.Shapes
        Call RecUngroupShape(sh)NextEndSub

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

こんな感じで、赤枠と画像の重ね合わせはグループ化しておくと便利。

RecUngroupShapeとUngroupAllShapesはひとつ前の記事で紹介しており、今回の処理に必須ではないがGroupingモジュールの仲間としては相応しと思ったのでついで。

以上