クリックすると、繋がっているシェイプの色が変わるExcelの相関図

とあるソフトウェア開発に携わっていたときのこと。
モジュールの複雑な相関関係をチェックするために、
理解しやすい相関図を作ることに。

Excelのオートシェイプを使ったのですが、
何と何が依存関係にあるのか分かりやすくするため、
クリックすると、そのシェイプに紐づくものに色が付くようにしました。 f:id:piyoco-garden:20160504232005g:plain 色が変わる部分の処理は、VBAで書いています。

相関図を書く

Excelのオートシェイプで相関図を作成します。今回は長方形とコネクタを使います。

長方形のシェイプを一つ作成します。
シェイプを右クリックして、「マクロの登録」をクリックします。
マクロ名を「OnClickShape」として、「新規作成」をクリックします。
長方形のシェイプにコネクタを接続します。
作ったシェイプを必要数分コピーします。コネクタとセットでコピペすると、作業が楽かもしれません。
テキストの入力や、配置の調整を行って相関図を完成させます。
コネクタの端点は、必ず長方形のシェイプと接続しておきます。

これで、長方形のシェイプをクリックすると、
「OnClickShape」というマクロが実行される相関図が完成しました。

色の定義

長方形のシェイプの色付けルールを決めます。
今回は、10色分定義します。
相関図の隣に、以下の様な表を作成します。

名前定義	色	説明
DefaultColor		デフォルト色
OutShapeColor4		クリックされたシェイプの4つ先のシェイプの色
OutShapeColor3		クリックされたシェイプの3つ先のシェイプの色
OutShapeColor2		クリックされたシェイプの2つ先のシェイプの色
OutShapeColor1		クリックされたシェイプの1つ先のシェイプの色
ClickedShapeColor		クリックされたシェイプの色
InShapeColor1		クリックされたシェイプの1つ前のシェイプの色
InShapeColor2		クリックされたシェイプの2つ前のシェイプの色
InShapeColor3		クリックされたシェイプの3つ前のシェイプの色
InShapeColor4		クリックされたシェイプの4つ前のシェイプの色

色の列には、任意の背景色を設定します。
↓こんな感じ。
f:id:piyoco-garden:20160504181043p:plain 上記B列の各セルに、名前定義の設定をしておきます。

$A$2:$B$11を選択します。
[数式]タブの[定義された名前]エリアにある[選択範囲から作成]をクリックします。
[左端列]にチェックを入れて[OK]をクリックします。

これで、B列の各セルには、A列に記載された名前が定義されます。

マクロの実装

シェイプがクリックされたときに実行するマクロを書いていきます。
大まかな処理ごとに説明していきます。

モジュール名の変更

「OnClickShape」というマクロを新規作成した際に、
「Module1」といった名前のモジュール内に関数が作成されていると思います。
モジュール名は、「ChangeColor」など、任意のものに変えておきます。

定数・変数の定義

変数名の付け方は自己流です。気になる方はすみません。

標準モジュールの宣言部には、以下を定義します。

Dim Color_Default As Long 'デフォルト色
Dim Color_ClickedShape As Long 'クリックされたシェイプの色
Dim Color_In(3) As Long 'クリックされたシェイプを指すシェイプの色
Dim Color_Out(3) As Long 'クリックされたシェイプが指すシェイプの色

Dim SheetName As String '相関図のシート名
Dim ShapeName_Clicked As String 'クリックされたシェイプの定義名
Dim ShapeName_In(3) As String 'クリックされたシェイプを指すシェイプの定義名
Dim ShapeName_Out(3) As String 'クリックされたシェイプが指すシェイプの定義名

Const CONECTOR_SHAPE = "Straight Arrow Connector *" 'コネクタの定義名
Const COLOR_CHANGE_SHAPE = "Rectangle*" '長方形の定義名

Color_Inは、クリックされたシェイプを指すシェイプの色、
Color_Outは、クリックされたシェイプが指すシェイプの色を示します。
配列の番号は、クリックされたシェイプからの距離に比例しており、
Color_In(0)は、クリックされたシェイプの1つ前のシェイプの色
Color_In(1)は、クリックされたシェイプの2つ前のシェイプの色
といった感じです。

ShapeName_Inは、クリックされたシェイプを指すシェイプの定義名、
ShapeName_Outは、クリックされたシェイプが指すシェイプの定義名
としています。こちらも、配列の番号は、クリックされたシェイプからの距離に比例しており、
ShapeName_In(0)には、クリックされたシェイプを指す全てのシェイプの定義名、
ShapeName_In(1)には、ShapeName_In(0)を指す全てのシェイプの定義名
が代入されます。

f:id:piyoco-garden:20160504214245p:plain

マクロを呼び出したシェイプの情報を取得する

クリックされたシェイプが配置されているシートのシート名と、
クリックされたシェイプの定義名を取得します。

'マクロを呼び出したシェイプの情報を取得する
Private Sub GetCallerInfo()
    SheetName = ActiveSheet.Name
    ShapeName_Clicked = Sheets(SheetName).Shapes(Application.Caller).Name
End Sub

シェイプの定義名は「Application.Caller」により、指定します。

設定する色の情報を取得する

先ほど名前定義したセルの背景色を取得します。

'設定する色の情報を取得する
Private Sub GetColorInfo()

    Dim nCount As Long
    
    '名前定義されたセルの背景色を取得する
    With Sheets(SheetName)
        Color_Default = .Range("DefaultColor").Interior.Color
        Color_ClickedShape = .Range("ClickedShapeColor").Interior.Color
        
        For nCount = 0 To 3
            Color_In(nCount) = .Range("InShapeColor" & nCount + 1).Interior.Color
            Color_Out(nCount) = .Range("OutShapeColor" & nCount + 1).Interior.Color
        Next
    End With
End Sub

色付け対象のシェイプのテキストを取得

まずは、クリックされたシェイプの定義名をもとに、
クリックされたシェイプに接続されているシェイプを探索します。

クリックされたシェイプのひとつ先のシェイプが見つかったら
そのまた先にあるシェイプを探索します。

4つ先まで色を定義したので、この探索を4回行います。

'色付け対象のシェイプのテキストを取得
Private Sub GetShapeName()
    Dim nCount As Long
    
    ShapeName_In(0) = GetNodeShapeName(ShapeName_Clicked, True)
    ShapeName_Out(0) = GetNodeShapeName(ShapeName_Clicked, False)
    
    For nCount = 1 To 3
        ShapeName_In(nCount) = GetNodeShapeName(ShapeName_In(nCount - 1), True)
        ShapeName_Out(nCount) = GetNodeShapeName(ShapeName_Out(nCount - 1), False)
    Next
End Sub

具体的な探索は、下記のように
シート上の全てのシェイプをチェックしていきます。

'コネクタの先にあるシェイプのテキストを取得する
'シェイプが複数接続されている場合は、「,」で区切りでテキストを連結する。
'CurrentShapeNameList：着目しているシェイプ名のリスト（「,」で区切る）
'bIn：True:着目しているシェイプ名を指し示すシェイプをチェック
'        False:着目しているシェイプ名が指し示すシェイプをチェック
Private Function GetNodeShapeName(CurrentShapeNameList As String, bIn As Boolean)
    
    Dim CurrentShapeName  '着目しているシェイプの定義名
    Dim NodeShapeList 'コネクタの先にあるシェイプのリスト
    Dim CurrentShape '着目しているシェイプ
    Dim buf
    
    NodeShapeList = ""
    buf = Split(CurrentShapeNameList, ",")
    For Each CurrentShapeName In buf
        If CurrentShapeName = "" Then GoTo Next_Text
        
        For Each CurrentShape In Sheets(SheetName).Shapes
            'コネクタシェイプをチェック
            If Not CurrentShape.Name Like CONECTOR_SHAPE Then _
                GoTo Next_Shape
            
            If bIn Then
                '着目しているシェイプを指し示しているコネクタの場合
                If CurrentShape.ConnectorFormat.EndConnectedShape.Name _
                    = CurrentShapeName Then
                    'そのコネクタの接続元のシェイプ名を取得する。
                    '接続元が複数存在する場合は、「,」で区切ってテキストを連結する。
                    NodeShapeList = NodeShapeList & "," _
                        & CurrentShape.ConnectorFormat.BeginConnectedShape.Name
                End If
            Else
                '着目しているシェイプから出ているコネクタの場合
                If CurrentShape.ConnectorFormat.BeginConnectedShape.Name _
                    = CurrentShapeName Then
                    'そのコネクタの接続先のシェイプ名を取得する。
                    '接続先が複数存在する場合は、「,」で区切ってテキストを連結する。
                    NodeShapeList = NodeShapeList & "," _
                        & CurrentShape.ConnectorFormat.EndConnectedShape.Name
                End If
            End If
Next_Shape:
        Next
Next_Text:
    Next
    GetNodeShapeName = NodeShapeList
End Function

着目しているシェイプを指すシェイプを探索する場合（bIn：True）
指定されたコネクタの終点が接続するシェイプを示す、
「EndConnectedShape」を利用します。

例えば、コネクタAのEndConnectedShape.Nameが、
シェイプBの定義名と一致する場合、
コネクタAの終点はシェイプBに接続していることになります。

このとき、コネクタAの始点に接続しているシェイプは
「BeginConnectedShape」によって取得できます。
「BeginConnectedShape」がシェイプCとすると、
シェイプBとシェイプCは、コネクタAによって接続されていることが分かります。

f:id:piyoco-garden:20160504223236p:plain

シェイプDの指す先に、シェイプEとシェイプFがつながっている場合、
「GetNodeShapeName(【シェイプD】, False)」を実行すると、
戻り値として「,E,F」が返ります。
更に、この「,E,F」を「GetNodeShapeName」の引数に指定すると、
シェイプEの先にあるシェイプ、シェイプFの先にあるシェイプが返ります。
（汚い実装で恥ずかしいですが・・・。）

ShapeName_In、ShapeName_Outに、戻り値を格納していくことで、
クリックされたシェイプからの距離ごとに、
接続されているシェイプの定義名を取得することができます。

シェイプの色を設定する

クリックされたシェイプからの距離ごとに、
シェイプの色を設定していきます。

ShapeName_In、ShapeName_Outに、
色付けの対象となるシェイプの定義名が格納されています。
なので、シート上の全シェイプをチェックし、
ShapeName_In／ShapeName_Outと一致すれば、距離に応じた色を設定します。

'シェイプの色を設定する
Private Sub SetShapeColor()
    
    Dim nCount As Long
    
    Sheets(SheetName).Shapes(Application.Caller).Fill.ForeColor.RGB _
        = Color_ClickedShape
    
    For nCount = 0 To 3
        Call SetColorEachDeapth(ShapeName_In(nCount), True, nCount)
        Call SetColorEachDeapth(ShapeName_Out(nCount), False, nCount)
    Next
End Sub

'クリックされたシェイプからの距離によって色を変える
'CurrentShapeNameList：着目しているシェイプ名のリスト（「,」で区切る）
'bIn：True:着目しているシェイプ名を指し示すシェイプをチェック
'        False:着目しているシェイプ名が指し示すシェイプをチェック
'nDepth：クリックされたシェイプからの距離
Private Sub SetColorEachDeapth(CurrentShapeNameList As String, bIn As Boolean, nDepth As Long)

    Dim buf() As String
    Dim CurrentShape
    Dim CurrentShapeName
    
    buf = Split(CurrentShapeNameList, ",")
    
    For Each CurrentShapeName In buf
        If CurrentShapeName = "" Then GoTo Next_Text
        
        For Each CurrentShape In Sheets(SheetName).Shapes
        
            If Not CurrentShape.Name Like COLOR_CHANGE_SHAPE Then _
                GoTo Next_Shape

            If CurrentShape.Name = CurrentShapeName Then
                CurrentShape.Fill.ForeColor.RGB _
                    = IIf(bIn, Color_In(nDepth), Color_Out(nDepth))
                GoTo Next_Text
            End If
Next_Shape:
        Next
Next_Text:
    Next
    
End Sub

データをクリア

以上で、色が付くようになったのですが、
連続でクリックされた場合に対応するため、
色付け前に前回の実行内容をクリアします。

コネクタの色や、その他のシェイプの色をクリアしてしまわないように、
長方形のシェイプの色だけを元に戻すようにしています。

'シェイプの色を既定に戻す
Private Sub ClearShapeColor()
    
    Dim CurrentShape
    For Each CurrentShape In Sheets(SheetName).Shapes
        '色を変える対象の図形でなければスキップ
        If Not CurrentShape.Name Like COLOR_CHANGE_SHAPE Then GoTo Next_Shape
        '既定の色になっていればスキップ
        If CurrentShape.Fill.ForeColor.RGB = Color_Default Then GoTo Next_Shape
        
        CurrentShape.Fill.ForeColor.RGB = Color_Default
            
Next_Shape:
    Next

End Sub

Private Sub ClearData()

    ClearShapeColor
    
    Erase ShapeName_In
    Erase ShapeName_Out
End Sub

クリック時に呼び出されるマクロ

クリック時に呼び出されるマクロ「OnShapeClick」の定義だけ作ってあったので、
中身を書きます。

Sub OnShapeClick()
    'マクロを呼び出したシェイプの情報を取得する
    GetCallerInfo
    'データをクリア
    ClearData
    '設定する色の情報を取得する
    GetColorInfo
    '色付け対象のシェイプのテキストを取得
    GetShapeName
    'シェイプの色を設定する
    SetShapeColor
End Sub

全ソースコード

お恥ずかしい限りですが、全ソースコードはこちらです。

Option Explicit

'■■■概要■■■
'あるオブジェクトをクリックすると、そのオブジェクトに接続しているオブジェクトに色付けを行う。

'■■■使い方■■■
'「正方形/長方形」の図形オブジェクト同士を「直線矢印コネクタ」で結ぶ。
'図形オブジェクトに「OnClickShape」マクロを登録する。
'---------------------------------------------------------------------------------------------

Dim SheetName As String '相関図のシート名
Dim ShapeName_Clicked As String 'クリックされたシェイプの定義名
Dim ShapeName_In(3) As String  'クリックされたシェイプを指すシェイプの定義名
Dim ShapeName_Out(3) As String 'クリックされたシェイプが指すシェイプの定義名

Dim Color_Default As Long 'デフォルト色
Dim Color_ClickedShape As Long   'クリックされたシェイプの色
Dim Color_In(3) As Long 'クリックされたシェイプを指すシェイプの色
Dim Color_Out(3) As Long 'クリックされたシェイプが指すシェイプの色

Const CONECTOR_SHAPE = "Straight Arrow Connector *" 'コネクタのシェイプの定義名
Const COLOR_CHANGE_SHAPE = "Rectangle*" '長方形のシェイプの定義名

'シェイプの色を既定に戻す
Private Sub ClearShapeColor()
    
    Dim CurrentShape
    For Each CurrentShape In Sheets(SheetName).Shapes
        '色を変える対象の図形でなければスキップ
        If Not CurrentShape.Name Like COLOR_CHANGE_SHAPE Then GoTo Next_Shape
        '既定の色になっていればスキップ
        If CurrentShape.Fill.ForeColor.RGB = Color_Default Then GoTo Next_Shape
        
        CurrentShape.Fill.ForeColor.RGB = Color_Default
            
Next_Shape:
    Next

End Sub

Private Sub ClearData()

    ClearShapeColor
    
    Erase ShapeName_In
    Erase ShapeName_Out
End Sub

'クリックされたシェイプからの距離によって色を変える
'CurrentShapeNameList：着目しているシェイプ名のリスト（「,」で区切る）
'bIn：True:着目しているシェイプ名を指し示すシェイプをチェック
'        False:着目しているシェイプ名が指し示すシェイプをチェック
'nDepth：クリックされたシェイプからの距離
Private Sub SetColorEachDeapth(CurrentShapeNameList As String, bIn As Boolean, nDepth As Long)

    Dim buf() As String
    Dim CurrentShape
    Dim CurrentShapeName
    
    buf = Split(CurrentShapeNameList, ",")
    
    For Each CurrentShapeName In buf
        If CurrentShapeName = "" Then GoTo Next_Text
        
        For Each CurrentShape In Sheets(SheetName).Shapes
        
            If Not CurrentShape.Name Like COLOR_CHANGE_SHAPE Then _
                GoTo Next_Shape

            If CurrentShape.Name = CurrentShapeName Then
                CurrentShape.Fill.ForeColor.RGB _
                    = IIf(bIn, Color_In(nDepth), Color_Out(nDepth))
                GoTo Next_Text
            End If
Next_Shape:
        Next
Next_Text:
    Next
    
End Sub

'シェイプの色を設定する
Private Sub SetShapeColor()
    
    Dim nCount As Long
    
    Sheets(SheetName).Shapes(Application.Caller).Fill.ForeColor.RGB _
        = Color_ClickedShape
    
    For nCount = 0 To 3
        Call SetColorEachDeapth(ShapeName_In(nCount), True, nCount)
        Call SetColorEachDeapth(ShapeName_Out(nCount), False, nCount)
    Next
End Sub

'コネクタの先にあるシェイプのテキストを取得する
'シェイプが複数接続されている場合は、「,」で区切りでテキストを連結する。
'CurrentShapeNameList：着目しているシェイプ名のリスト（「,」で区切る）
'bIn：True:着目しているシェイプ名を指し示すシェイプをチェック
'        False:着目しているシェイプ名が指し示すシェイプをチェック
Private Function GetNodeShapeName(CurrentShapeNameList As String, bIn As Boolean)
    
    Dim CurrentShapeName  '着目しているシェイプの定義名
    Dim NodeShapeList 'コネクタの先にあるシェイプのリスト
    Dim CurrentShape '着目しているシェイプ
    Dim buf
    
    NodeShapeList = ""
    buf = Split(CurrentShapeNameList, ",")
    For Each CurrentShapeName In buf
        If CurrentShapeName = "" Then GoTo Next_Text
        
        For Each CurrentShape In Sheets(SheetName).Shapes
            'コネクタシェイプをチェック
            If Not CurrentShape.Name Like CONECTOR_SHAPE Then _
                GoTo Next_Shape
            
            If bIn Then
                '着目しているシェイプを指し示しているコネクタの場合
                If CurrentShape.ConnectorFormat.EndConnectedShape.Name _
                    = CurrentShapeName Then
                    'そのコネクタの接続元のシェイプ名を取得する。
                    '接続元が複数存在する場合は、「,」で区切ってテキストを連結する。
                    NodeShapeList = NodeShapeList & "," _
                        & CurrentShape.ConnectorFormat.BeginConnectedShape.Name
                End If
            Else
                '着目しているシェイプから出ているコネクタの場合
                If CurrentShape.ConnectorFormat.BeginConnectedShape.Name _
                    = CurrentShapeName Then
                    'そのコネクタの接続先のシェイプ名を取得する。
                    '接続先が複数存在する場合は、「,」で区切ってテキストを連結する。
                    NodeShapeList = NodeShapeList & "," _
                        & CurrentShape.ConnectorFormat.EndConnectedShape.Name
                End If
            End If
Next_Shape:
        Next
Next_Text:
    Next
    GetNodeShapeName = NodeShapeList
End Function

'色付け対象のシェイプのテキストを取得
Private Sub GetShapeName()
    Dim nCount As Long
    
    'ShapeName_In/ShapeName_Out
    'シェイプのテキスト名を取得
    '0番目の要素は、クリックされたシェイプ、
    '1番目の要素は、クリックされたシェイプを指し示しているシェイプ／クリックされたシェイプが指し示しているシェイプ
    '2番目の要素は、1番目の要素のシェイプを指し示しているシェイプ／1番目の要素のシェイプが指し示しているシェイプ

    ShapeName_In(0) = GetNodeShapeName(ShapeName_Clicked, True)
    ShapeName_Out(0) = GetNodeShapeName(ShapeName_Clicked, False)
    
    For nCount = 1 To 3
        ShapeName_In(nCount) = GetNodeShapeName(ShapeName_In(nCount - 1), True)
        ShapeName_Out(nCount) = GetNodeShapeName(ShapeName_Out(nCount - 1), False)
    Next
End Sub

'設定する色の情報を取得する
Private Sub GetColorInfo()

    Dim nCount As Long
    
    '名前定義されたセルの背景色を取得する
    With Sheets(SheetName)
        Color_Default = .Range("DefaultColor").Interior.Color
        Color_ClickedShape = .Range("ClickedShapeColor").Interior.Color
        
        For nCount = 0 To 3
            Color_In(nCount) = .Range("InShapeColor" & nCount + 1).Interior.Color
            Color_Out(nCount) = .Range("OutShapeColor" & nCount + 1).Interior.Color
        Next
    End With
End Sub

'マクロを呼び出したシェイプの情報を取得する
Private Sub GetCallerInfo()
    SheetName = ActiveSheet.Name
    ShapeName_Clicked = Sheets(SheetName).Shapes(Application.Caller).Name
End Sub

Sub OnShapeClick()
    'マクロを呼び出したシェイプの情報を取得する
    GetCallerInfo
    'データをクリア
    ClearData
    '設定する色の情報を取得する
    GetColorInfo
    '色付け対象のシェイプのテキストを取得
    GetShapeName
    'シェイプの色を設定する
    SetShapeColor
End Sub

Excel方眼紙からの脱却

VBAのことと、その他いろいろメモ。