VBA オートシェイプの吹き出しの剣先を狙った位置に表示させるマクロ

オートシェイプを扱うマクロで特にややこしいのがAdjustmentsプロパティの調整だ。

Adjustmentsはシェイプを選択したときに黄色のハンドルが表示されるもので、ドラッグすることで調整ができる。
説明などでよく利用される吹き出しもAdjustmentsプロパティを持っている。
f:id:t-hom:20180610010746p:plain

さて、今回は吹き出しが狙った項目を指すように、剣先の位置を調整するマクロを紹介する。

今回作るもの

今回は吹き出しと四角形が適当に配置された状態から、吹き出しの剣先を四角形の左上隅に移動させるマクロを作成する。
f:id:t-hom:20180610011637p:plain

準備

実際のマクロではシェイプの挿入や特定もマクロで行うことが多いけれど、今回は説明用なので割愛し、シェイプの名前で特定することにする。

下図のように調べたいシェイプを選択した状態で、イミディエイトウィンドウに「?Selection.Name」と入力するとシェイプの名前が特定できる。
f:id:t-hom:20180610010541p:plain

今回は吹き出しと、適当な赤枠四角形を挿入して名前を調べておこう。

私の環境では吹き出しが「Rounded Rectangular Callout 26」、赤枠が「Rectangle 25」という名称だった。

コード

コードは次のとおり。

Sub SampleAdjustCalloutToTargetFrame()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    Dim frame As Shape
    Set frame = Sheet1.Shapes("Rectangle 25")

    Dim topDistance As Single: topDistance = frame.Top - callout.Top
    Dim leftDistance As Single: leftDistance = frame.Left - callout.Left
    callout.Adjustments.Item(1) = (leftDistance / callout.Width) - 0.5
    callout.Adjustments.Item(2) = (topDistance / callout.Height) - 0.5
End Sub

これを実行すると吹き出しの剣先が赤枠の左上隅に移動する。
f:id:t-hom:20180610012026p:plain

解説

肝となるのはAdjustmentsの挙動である。
AdjustmentsのItem(1)は横軸の位置を、Item(2)は縦軸の位置を表すが、この数値が共にゼロのとき、ちょうど吹き出しの中央に来る。

次のコードで試してみよう。

Sub SampleAdjustCalloutToZero()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = 0
    callout.Adjustments.Item(2) = 0
End Sub

実行すると黄色いハンドルが中央に来る。
f:id:t-hom:20180610012448p:plain

このItem(1)は吹き出し本体の幅に対する比率で、正の数を指定すると剣先は右へ伸び、負の数を指定すると剣先は左へ延びる。
同様にItem(2)は高さに対する比率となっており、正の数を指定すると剣先は下へ伸び、負の数を指定すると剣先は上へ延びる。

次のコードはItem(1)のみ1にしたものである。

Sub SampleAdjustCalloutToOneZero()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = 1
    callout.Adjustments.Item(2) = 0
End Sub

実行すると剣先はこのような位置にくる。
f:id:t-hom:20180610013310p:plain

これは吹き出し中央から右にちょうど本体1個分のサイズ移動したところが剣先になるということ。
f:id:t-hom:20180610013236p:plain

さて、ここから計算を容易にするため、シェイプのTopとLeftの値の位置に剣先を飛ばすよう補正をかけてみよう。

Sub SampleAdjustCalloutToTopLeft()
    Dim callout As Shape
    Set callout = Sheet1.Shapes("Rounded Rectangular Callout 26")
    callout.Adjustments.Item(1) = -0.5
    callout.Adjustments.Item(2) = -0.5
End Sub