集中線を作成するしょうもないマクロの作り方【Excel VBA】

f:id:tdyu5021:20201120211445j:plain
以前Twitterに投稿したくだらないExcel VBAマクロシリーズです。需要はないだろうと思いますが、想像以上にバズったので、せっかくなのでその作り方を解説してみます。

集中線を作成するExcelマクロとは

まず以下のTwitterの投稿をご覧ください。集中線を作成するプログラムを実行した画面動画です。

仕事でExcelの資料を作ってるとき、「ここを強調したい！」っていうシーンありませんか？そんな方のために、丸で囲んで簡単に集中線をつけられるExcelアドインを開発しました～#Excel　#VBA pic.twitter.com/UUQxm0rrtV
— (有) (@tdyu05) December 21, 2019

「集中線」とは強調したものを目立たせるために放射上に周囲に線を引いた表現です。よくマンガで見かけるやつですね。

別にそこまでウケ狙いで作ったわけではないのですが、あまりにも線を増やし過ぎたせいで見た目のインパクトが強烈になり、

強調しすぎて他が見えなくなってるじゃねーかｗｗｗ

そこ以外が見づれぇwwwww

などなど、いろんな方からのツッコミとともに結構バズってしまいました。中には「作り方を教えて下さい」というコメントもあったので、だいぶ今さら感はありますが、作成方法を紹介します。ソースコードは最後にまとめて掲載します。

円周上にオブジェクトを配置する

このプログラムは、実際のコードを順を追って解説する前に、まず「円周上にオブジェクトを配置する」方法を解説します。正直これさえわかれば後は簡単です。

円周上にオブジェクトを配置するとはどういうことかというと、例えば以下のような形を作成することです。

f:id:tdyu5021:20201017001726p:plain

これはオートシェイプを作成する「AddShapeメソッド」を、X座標、Y座標をずらしながら18回ループさせて円を配置したものです。ただ、通常のループの中で円の軌道をどうやって描けばよいでしょうか。

例えば直線上にオブジェクトを連続で配置していくには、X座標あるいはY座標の値をループで足していけばよいのですが、円周に沿って配置していく場合は単純にはいきません。

これは「円周上の座標の位置の求め方」を利用して対処します。その求め方は以下になります。

X座標…中心の座標＋半径×Sinθ
Y座標…中心の座標＋半径×Cosθ

f:id:tdyu5021:20201024225818p:plain

上記の式からわかるように、角度のθの値でX座標、Y座標は変化するので、θの値を変数にしてループさせればよいのです。サインθとコサインθの値は、VBAで標準で用意されている「Sin関数」と「Cos関数」を使用して求めます。この2つの関数は、Sin(X),Cos(X)のように記述し、Xに角度の数値の引数を入れて使用します。

角度をラジアンに変換する

ただ注意点として、このSin関数とCos関数の引数の角度の単位は、「ラジアン」を用います。そのため小学校の頃から慣れ親しんだ「度数」で管理したい場合、度数からラジアンへ変換するコードを挟まないといけません。

度数からラジアンへの変換自体は、

ラジアン=度数×(π/180)

で求められるので一見すると簡単ですが、なんと残念ながらVBAには円周率（π）を求める関数が存在しません。ですから円周率を何らかの方法で導く必要があります。

Excelのワークシート関数にはPi関数があるのでそれを使用してもよいですが、どうやら調べたところによると、アークタンジェントを求める「Atn関数」を用いて

Atn(1)×4

でも円周率（π）を求められるそうです。なぜ上記の式で円周率を求められるのか、私は理屈を説明できませんが、以下の記事に詳しく書いてあるので気になる方は読んでみてください。

excelmath.atelierkobato.com

まとめとして、度数の変数をdegreeと置いた上で、Excel VBAで度数をラジアンに変換する記述は以下になります。

Pi = 4 * Atn(1) '//ここで円周率πを求める
radian = degree * (Pi / 180)

円周上にオブジェクトを配置するコード

これを踏まえて、円周上に図形を配置するコードをまとめてみます。円の中心となるX座標、Y座標の変数をcenterX、centerYに、また半径の変数をRadiusにして、ひとまずここでは適当な数値を入れておきます。

配置する円については、上記サンプル画像のように18個配置したい場合は、360÷18＝20、つまりループで20度ずつステップさせています。

Sub test()
    centerX = 200  '//円の中心となるX座標
    centerY = 200  '//円の中心となるY座標
    Radius = 100   '//円の半径
    For Degree = 1 To 360 Step 20
            Pi = 4 * Atn(1)
            radian = Degree * (Pi / 180)
            
            x = centerX + Radius * Sin(radian)
            y = centerY + Radius * Cos(radian)
                
            Dim s As Shape
            Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, x, y, 20, 20)
    Next
End Sub

試しに上記のコードをコピペして実行してみてください。最初にお見せした画像のように円周上に配置されるはずです。

集中線を作成してみる

それでは今回の本題である集中線を実現するために、そのほか必要なポイントを見ていきましょう。

AddConnector メソッドで線を引く

まず集中線に必要な「線」はオートシェイプの「線（コネクタ）」を作成するメソッドであるAddConnectorメソッドを使います。

このメソッドは

Addconnector(Type、 [beginx]、 [beginy]、 [endx]、 [endy])

のように5つの引数を取ります。

[beginx]、 [beginy]はコネクタの開始位置のX座標、Y座標で、

[beginx]、 [beginy]は終了位置のX座標、Y座標です。

上記で円周上の座標の求め方を紹介しましたが、開始位置のX座標、Y座標は小さめの円周に、終了位置のX座標、Y座標は大きめの円周に沿って配置すれば線を放射上に配置することができます。

試しに、上に記した円周上に配置するコードのうち、Radiusの値を小さめに設定した上で該当部分を以下のように書き換えてみてください。

x = centerX + Radius * Sin(radian)
y = centerY + Radius * Cos(radian)
x2 = centerX + (50 + Radius) * Sin(radian)
y2 = centerY + (50 + Radius) * Cos(radian)

Dim s As Shape
Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x, y, x2, y2)

線（コネクタオブジェクト）が放射上に並ぶはずです。

そのほか集中線っぽくするためのチューニング

ただ、放射上に線を配置しただけでは旭日旗みたいな模様になり、集中線っぽくはなりません。これを解消するために以下の調整をかけています。

線ごとに開始位置を変える
線と線の間隔は等間隔でなくバラバラにする
線ごとに先の太さを変える

サンプルコードを例に取ると、今回のマクロでは、

1については変数Radiusの値をランダムに生成

2については変数Degreeをランダムに生成してForループで大量発生

（このループの回数が多くなればなるほど線が増えるので集中度合いが増します）

3については、コネクタオブジェクトのLine.Weightプロパティで太さをランダムで1か2にする、というふうにしています。

楕円オブジェクトを中心に線を伸ばす

集中線自体の作成は以上です。ただ最初のTwitter内の動画でもおわかりの通り、このマクロははじめに楕円オブジェクトを作り、もしワークシート上に楕円オブジェクトが見つかれば、その円周上を開始X座標、開始Y座標にして線を生成するという処理を行っていますので、その部分をご紹介します。

この処理を実現するには、

楕円オブジェクトと中心のX座標・Y座標
楕円オブジェクトの直径（今回は楕円の横幅を想定してプログラムを作っています）

の情報を取得しておきます。中心の座標はシェイプオブジェクトのTopやLeft、Width、Heightを用いて簡単に求められます。以下の画像の通りです。

f:id:tdyu5021:20201024212419p:plain

真円ではなく楕円状に配置する

この記事のはじめに、円周上にオブジェクトを配置する例を示しましたが、その円は完全な真ん丸（真円）でした。これを楕円にする場合、単純に拡大したい方向に任意の値を掛け算すればOKです。

一応書いておくと、座標を求める部分を以下のようにすると、横幅の直径が縦幅の直径の2倍の楕円ができます。

x = centerX + Radius * Sin(radian)*2
y = centerY + Radius * Cos(radian)

今回の集中線では、線の開始位置をプロットする円の直径は横幅（＝X軸方向）を基準にしています。

そのため、楕円の縦の直径が横の直径と異なる場合は、その比率を縦幅の方に加味してあげる必要があります（例：楕円の縦幅が横幅の1/2なら、X座標を求める式に÷2をする）

この処理を書いておけば縦長、横長どちらの楕円にも対応できる集中線を作成できます。

補足：この集中線の欠陥

実はこのコードには重大な欠点があります。画面をある程度縮小していても集中線で画面を覆えるようにするために、中心から線の開始位置までの長さと中心から線の終了位置までの長さを1000というかなり大きめの値に設定しています。

ただその長さを固定にしてしまうと、線の終端座標がワークシートの左端や上端をオーバーしてしまう可能性があり、そうなるとうまく対応できないのです。

ちなみにシェイプオブジェクトでTopとLeftが0未満になった場合は、自動で0として扱われるため、線の長さはそのままに線の終端座標が0を基準として図形が勝手に動かされてしまいます。

この対策として「最初に楕円を置いた場所によって上側、左側にある線の長さを変える」という方法もなくはないのですが、うまくいかなかったので今回は妥協しました。とりあえず、「線の終端座標のX座標、Y座標が0未満になった場合は値を0にする」という処理で逃げましたが、それをやっても以下みたいな感じになってしまい、完璧に対処はできていません。

f:id:tdyu5021:20201024222412p:plain

実際にできあがったコード

最後に今回作成したコードを紹介します。実用される方はまずいないと思いますが、試しにご自身のワークシートなどで遊んでみてもらえれば幸いです。

Sub createLines()
    Randomize
    Dim shp As Shape
    Dim s As Shape
    Dim flg As Boolean
    Dim target As Shape

    '//ワークシート内の楕円を探す
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then
          flg = True
          Set target = shp
          Exit For
      End If
    Next shp
    '//楕円が見つからなかったらマクロ終了
    If flg = False Then Exit Sub

    w = target.Width
    h = target.Height
    targetLeft = target.Left
    targetTop = target.Top
    
    '//楕円の中心のX,Y座標
    centerX = targetLeft + w / 2
    centerY = targetTop + h / 2
    
    ratio = w / h
    '//楕円を削除
    target.Delete

    For i = 0 To 360
        Radius = w / 2  '//楕円の半径
        Degree = Int(Rnd * 360) '//ランダムに角度を決定する
        '//↓↓↓角度をラジアンに変換する
        Pi = 4 * Atn(1)
        radian = Degree * (Pi / 180)
        '//↑↑↑
        
        gosa = Int(Rnd * 70) '//線を開始位置をばらつかせるためランダムな誤差を発生
        
        '//線の開始地点、終了地点を円状にプロット
        x = (Radius + gosa) * Sin(radian)
        y = (Radius + gosa) * Cos(radian) / ratio
        x2 = (Radius + 1000 + gosa) * Sin(radian)
        y2 = (Radius + 1000 + gosa) * Cos(radian) / ratio
        
        '//楕円の位置を基準にする
        x = centerX + x
        x2 = centerX + x2
        y = centerY + y
        y2 = centerY + y2
           
        '//↓線を伸ばした先が画面を越える場合の対策
        If x2 < 0 Then '//もし画面の最左端を超えたら
            x2 = 0     '//とりあえずx座標は0に
        End If
        If y2 < 0 Then '//もし画面の最上端を超えたら
            y2 = 0     '//とりあえずy座標は0に
        End If
        '//↑
        
        Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x, y, x2, y2)
        weightNum = Int(Rnd * 2) + 1
        s.Line.Weight = weightNum
        s.Line.ForeColor.RGB = RGB(0, 0, 0)
    Next
End Sub