【Excel VBA】矩形Shape同士の包含関係を文章で出力する

13227 ワード
VBA Excel 自分用メモ Excel テキストリンク

概要

Excelで、アクティブシート上にある矩形テキストボックスの包含関係を「XはAとBとCを有する。」等の文章にして出力する。

きっかけ/用途

コンピュータソフトウェア関係の特許を出願するとき、「コンピュータ１００は、記憶部１１０及び計算部１２０を有する。」のようなことを明細書に書くことがあるのですが、同じようなことを図面に描いてあるので、二度手間防止+ミス防止のために図面から文章を生成したかったのです。1

処理

包含関係

私は数学の事はよく分かりませんが、とりあえずWikipediaの「部分集合」の定義に従い、ある図形に他の図形が全部含まれているかどうかで判断することにしましょう。
https://ja.wikipedia.org/wiki/%E9%83%A8%E5%88%86%E9%9B%86%E5%90%88

同じ軸上の2つの線分の最小値と最大値を入れたら、前者が後者を含んでいるかどうか判定する関数を作ります。
矩形どうしであれば、これをX座標とY座標で2回判定すればいいのです。

Private Function AIncludesB(Amin, Amax, Bmin, Bmax) As Boolean
    AIncludesB = False
    If (Amin <= Bmin) And (Amax >= Bmax) Then
        AIncludesB = True
    End If
End Function

図形同士の包含関係を取得

図形関係の包含関係を取得して二次元配列に保存します。2
図形iが図形jを包含するとき、arrShps(i,j) = Tureとしましょう。
このときiのことを親Shape、jのことを子Shapeとでもいうことにします。

ただ、例えばi>j>k関係になっているとして、記載するのは直接の親子関係にあるi>j、j>kの関係のみです。
なので、iがjを包含しているとして、孫Shapeのkは除外します。


Sub ShpInclude()
    Dim i As Long, j As Long, k As Long

    Dim ShapesCnt
    ShapesCnt = ActiveSheet.Shapes.Count  'ここ代入しないとなぜかエラーになる
    Dim arrShps()
    ReDim Preserve arrShps(1 To ShapesCnt, 1 To ShapesCnt)

    Dim hasChild As Variant
    Dim strOutput As String

    With ActiveSheet

        For i = 1 To ShapesCnt
            For j = 1 To ShapesCnt
                If i <> j Then
                    If AIncludesB(.Shapes(i).Left, .Shapes(i).Left + .Shapes(i).Width, .Shapes(j).Left, .Shapes(j).Left + .Shapes(j).Width) And AIncludesB(.Shapes(i).Top, .Shapes(i).Top + .Shapes(i).Height, .Shapes(j).Top, .Shapes(j).Top + .Shapes(j).Height) Then
                        Debug.Print (.Shapes(i).TextFrame2.TextRange.Text & "⊇" & .Shapes(j).TextFrame2.TextRange.Text)
                        'Shapeが子Shapeを持っているか定義する
                        arrShps(i, j) = True
                    End If
                End If
            Next
        Next

        '子Shapeにさらに子Shape(孫Shape=k)がいる場合、その孫Shapeを除外
        For i = 1 To ShapesCnt
            hasChild = 0
            strOutput = ""
            For j = 1 To ShapesCnt
                If arrShps(i, j) Then
                    hasChild = hasChild + 1
                    For k = 1 To ShapesCnt
                        If arrShps(j, k) And arrShps(i, k) Then
                            arrShps(i, k) = False
                        End If
                    Next
                End If
            Next

            '「XはAとBとCからなり、Aはaからなる」等の文章を出力
            'ここでは「XはAとBとCを有する」等を出力
            If hasChild Then
                strOutput = .Shapes(i).TextFrame2.TextRange.Text & "は、"
                For j = 1 To ShapesCnt
                    If arrShps(i, j) Then
                        strOutput = strOutput & .Shapes(j).TextFrame2.TextRange.Text & "と、"
                    End If
                Next
                strOutput = strOutput & "を有する。"
            End If
            Range("A" & i + 1).Value = strOutput
        Next
    End With

End Sub

実行例と結果

右の図から左の文章が一応できました。
ちょっと手直し3が必要ですが、まぁまぁではないでしょうか。

  1. 創作モノの設定書/企画書から組織など文章に起こすのにも応用できそう。「A国にはBとCとDの地域がある」とか。 ↩

  2. VBAでノードを扱えるものとしてTreeViewコントロールというのがあるようですが、まだ試してないです。 ↩

  3. 順番とか、子Shapeが1つだけのときの処理とか。引出し線・符号とかの処理は厄介なので後で何とかします…… ↩