VBA: 円状にランダムに点を打つマクロ

Author: detourist

14 1月

Visio 上で，指定した座標を中心にランダムに点を打つマクロ．ここでは，使用イメージのように点の密度が中央に偏るようにしている．

なお，Excel 関数の標準正規分布関数 NormSInv を使用するため，VBA から Excel オブジェクトライブラリを参照するために，あらかじめ以下の操作が必要．
(1) Visio にて，[ツール] → [マクロ] → 「Visial Basic Editor」を開く．
(2) Visual Basic Editor にて，[ツール] → [参照設定] → 「Microsoft Excel 9.0 Object Library」を選択 → [OK]
(*) その後，コードを編集し，保存．

使い方は，「実行するマクロ」内の値を適当に修正し，[ツール] → [マクロ] から「実行するマクロ」を実行．
※なぜ「drawPoints」を別のプロージャ（「実行するマクロ」）から呼び出しているかというと，引数を変えた複数の drawPoints を同時に実行できるようにするため．

Sub 実行するマクロ()
    drawPoints 100, 100, 1000, 50
End Sub

Sub drawPoints(x, y, n, r)
    'x = 中心のX座標
    'y = 中心のY座標
    'n = 描画する点の個数
    'r = 点の散らばる範囲を調整する値

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Microsoft Excel 9.0 Object Library を参照
    Dim objExcel As Excel.Application
    Set objExcel = CreateObject("Excel.Application")

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim myCircle() As Visio.Shape
    '配列生成時に変数(ここでの n )を利用できないため ReDim を使用
    ReDim myCircle(n)

    i = 0
    Do While i < n
        drawX = x + objExcel.Application.NormSInv(Rnd) * r
        drawY = y + objExcel.Application.NormSInv(Rnd) * r

        '※描画する点の大きさは 2 に固定．手抜き．．．
        drawX1 = drawX - 1
        drawX2 = drawX + 1
        drawY1 = drawY + 1
        drawY2 = drawY - 1

        '点を描画
        Set myCircle(i) = ThisDocument.Application.ActiveWindow.Page.DrawOval(drawX1, drawY1, drawX2, drawY2)
        '塗りつぶし色を変更
        myCircle(i).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(0,32,96))"
        '透過度を変更
        'myCircle(i).CellsSRC(visSectionObject, visRowFill, visFillForegndTrans).FormulaU = "50%"
        '線をなしにする
        myCircle(i).CellsSRC(visSectionObject, visRowLine, visLinePattern).FormulaU = "0"
        'レイヤを変更する
        'myCircle(i).CellsSRC(visSectionObject, visRowLayerMem, visLayerMember).FormulaForceU = """5"""

        'カウンタを進める
        i = i + 1
    Loop

    'ReDim したオブジェクトは Erase するお約束(？)
    Erase myCircle()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub

0 Comments