【Word VBA】かもめ描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub かもめ描画マクロ()

    Const GULLCALF = 75　   'キャンバス位置Ｘ

    Const GULLCATP = 50 　  '                    Ｙ

    Const GULLCAWD = 360  'キャンバス幅

    Const GULLCAHT = 240   'キャンバス高さ

    Const GULLCABC = &HFF901E     '背景色

    '

    Const GULLBZM1 = 2      'ベジェ描画倍率1

    Const GULLBZM2 = 3      'ベジェ描画倍率2

    '

    Const GULLROWS = 4     '描画数（縦）

    Const GULLCOLS = 4      '描画数（横）

    Const CULLCONT = GULLROWS * GULLCOLS

    '---------------------------------------------------------------------------

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    '

    Dim shpCanv As Shape

    Dim varBezi As Variant

    Dim sngBBs1() As Single, sngBBs2() As Single

    Dim sngBBs3() As Single, sngBBs4() As Single

    Dim sngBDat() As Single

    '

    'かもめベジェデータ(１)

    varBezi = Array(-1.34, 2.14, -1.04, 3.05, -2.28, 2.92, -3.16, 3.2, -3.81, 3.45, -3.78, 4.14, -3.46, 4.48, -3.11, 4.86, -2.01, 5.67, -1.61, 5.83, -1.11, 6.23, -0.78, 5.02, -0.34, 3.08, -0.18, 2.98, 0.13, 3.86, 1.09, 4.05, 1.86, 3.64, 2.84, 2.64, 2.86, 2.02, 2.54, 1.64, 1.66, 1.36, 1.84, 0.55, 1.83, 0.08, 2.44, -0.45, 3.09, -1.45, 3.56, -2.02, 3.94, -2.7, 4.29, -2.73, 4.63, -2.77, 5.36, -2.55, 5.83, -2.61, 6.53, -2.86, 7.29, -3.36, 7.93, -3.89, 8.46, -4.42, 8.94, -4.7, 8.49, -4.89, 7.39, -5.2, 5.59, -5.45, 4.29, -5.55, 3.16, -4.73, 2.73, -3.73, 2.14, -2.86, 1.53, -1.89, 1.03, -0.33, 0.24, 0.05, -0.68, -0.11, -1.28, -1.55, -2.06, -2.55, -2.86, -3.52, -3.48, -5.39, -4.46, -5.83, -6.01, -5.23, -6.96, -4.36, -7.66, -3.67, -8.24, -3.42, -8.96, -3.23, -8.96, -2.8, -8.94, -2.36, -8.14, -1.27, -7.56, -1.08, -6.98, -0.89, -6.28, -1.23, -5.66, -1.77, -5.11, -2.02, -5.11, -2.86, -4.46, -2.3, -3.28, -1.05, -1.64, 1.23, -1.34, 2.14)

    ReDim sngBBs1(UBound(varBezi, 1) \ 2, 1)

    For Kp = LBound(sngBBs1, 1) To UBound(sngBBs1, 1)

        sngBBs1(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) * GULLBZM2

        sngBBs1(Kp, 1) = CSng(varBezi(Kp * 2 + 1)) * GULLBZM1

    Next Kp

    'かもめベジェデータ(２)

    varBezi = Array(-1.01, 1.48, -0.88, 1.98, -2.06, 4.05, -1.64, 4.05, -1.18, 4.02, 0.59, 2.89, 1.59, 1.39, 2.26, 0.36, 1.96, -1.27, 2.36, -2.14, 2.79, -3.05, 3.33, -3.64, 4.06, -3.92, 4.84, -4.23, 6.29, -3.8, 6.94, -3.98, 7.59, -4.17, 7.56, -5.23, 8.94, -5.61, 7.79, -5.8, 5.73, -6.02, 4.54, -5.58, 3.36, -5.14, 2.03, -3.98, 1.29, -3.11, 0.56, -2.23, 0.74, -0.7, 0.14, -0.3, -0.44, 0.14, -1.41, -0.3, -2.18, -0.52, -2.96, -0.73, -3.78, -1.77, -4.44, -1.64, -5.08, -1.48, -5.46, -0.67, -6.11, 0.36, -6.78, 1.36, -7.98, 3.58, -8.41, 4.42, -8.86, 5.27, -8.98, 5.14, -8.31, 5.98, -7.06, 6.8, -5.96, 4.23, -5.54, 3.42, -5.01, 2.05, -4.31, 0.83, -2.88, 1.05, -1.94, 1.17, -1.14, 1.02, -1.01, 1.48)

    ReDim sngBBs2(UBound(varBezi, 1) \ 2, 1)

    For Kp = LBound(sngBBs2, 1) To UBound(sngBBs2, 1)

        sngBBs2(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) * GULLBZM1

        sngBBs2(Kp, 1) = CSng(varBezi(Kp * 2 + 1)) * GULLBZM1

    Next Kp

    'かもめベジェデータ(３)

    varBezi = Array(2.99, 2.45, 3.33, 2.86, 5.09, 1.98, 5.39, 2.14, 5.66, 2.23, 4.69, 3.27, 4.13, 4.3, 3.36, 4.55, 2.76, 4.7, 1.89, 4.86, 1.19, 3.45, -0.01, 4.42, -1.06, 4.52, -1.41, 4.83, -1.88, 4.48, -1.98, 4.7, -1.88, 4.2, -1.24, 3.8, -1.36, 3.73, -1.51, 3.67, -2.24, 3.8, -2.68, 3.92, -3.34, 4.23, -4.04, 4.39, -4.76, 4.83, -5.48, 5.3, -6.18, 5.86, -7.26, 6.98, -8.08, 7.48, -8.74, 7.61, -8.96, 6.8, -8.64, 6.05, -8.16, 5.48, -7.61, 5.05, -7.06, 4.64, -6.16, 4.2, -5.46, 3.89, -4.76, 3.58, -4.14, 3.39, -3.41, 3.14, -1.68, 2.73, -0.48, 2.23, 0.23, 1.7, 0.54, 1.17, 0.79, -0.92, 1.14, -2.39, 1.46, -3.77, 1.23, -4.73, 1.83, -4.95, 2.34, -5.45, 3.49, -5.67, 4.46, -6.02, 5.44, -6.39, 6.93, -6.86, 7.66, -7.05, 8.39, -7.27, 8.94, -7.52, 8.89, -7.36, 8.76, -6.52, 7.96, -6.55, 7.43, -6.08, 6.16, -5.27, 5.06, -4.23, 4.14, -2.95, 3.79, -2.23, 3.73, -1.42, 3.53, -0.61, 3.33, 0.23, 2.69, 1.98, 2.99, 2.45)

    ReDim sngBBs3(UBound(varBezi, 1) \ 2, 1)

    For Kp = LBound(sngBBs3, 1) To UBound(sngBBs3, 1)

        sngBBs3(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) * GULLBZM1

        sngBBs3(Kp, 1) = CSng(varBezi(Kp * 2 + 1)) * GULLBZM1

    Next Kp

    'かもめベジェデータ(４)

    varBezi = Array(-5.51, 1.39, -6.11, 2.14, -8.01, 2.33, -8.04, 2.86, -8.04, 3.42, -6.88, 4.05, -5.76, 4.8, -4.78, 5.3, -3.96, 5.89, -3.01, 5.86, -1.54, 5.58, -0.08, 5.05, 0.13, 4.55, 0.33, 4.05, -1.44, 3.92, -1.76, 2.8, -1.71, 2.02, -0.56, 1.17, 0.26, -0.2, 0.96, -1.05, 1.33, -2.14, 1.86, -2.42, 2.39, -2.7, 2.93, -2.02, 3.63, -1.83, 4.34, -1.64, 5.39, -1.27, 6.86, -1.2, 8.06, -1.52, 8.86, -2.11, 8.44, -2.58, 8.03, -3.05, 6.54, -3.86, 5.54, -4.33, 4.09, -5.08, 1.54, -5.8, 0.04, -5.92, -0.68, -5.73, -1.14, -4.8, -1.81, -3.3, -2.96, -0.92, -3.31, 0.95, -3.74, 0.73, -4.16, 0.52, -4.91, -1.39, -5.51, -2.23, -6.11, -3.05, -6.81, -4.27, -7.38, -4.27, -7.94, -4.27, -8.34, -3.48, -8.86, -2.23, -8.86, -1.33, -8.84, -0.33, -8.21, 0.36, -7.96, 0.23, -7.38, -0.52, -6.61, -0.77, -6.04, -0.45, -5.36, 0.52, -5.51, 1.39)

    ReDim sngBBs4(UBound(varBezi, 1) \ 2, 1)

    For Kp = LBound(sngBBs4, 1) To UBound(sngBBs4, 1)

        sngBBs4(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) * GULLBZM1

        sngBBs4(Kp, 1) = CSng(varBezi(Kp * 2 + 1)) * GULLBZM1

    Next Kp

    '

    '*キャンバス設定

    Set shpCanv = _

    ActiveDocument.Shapes.AddCanvas( _

                   GULLCALF, GULLCATP, GULLCAWD, GULLCAHT)

    With shpCanv

        .Fill.Visible = msoTrue

        .Fill.ForeColor.RGB = GULLCABC '←背景色（空）

        '

        Randomize '*乱数系列初期化

        For Ip = 0 To CULLCONT - 1

            '*描画座標取得

            intDxp = (GULLCAWD \ 4) * (Ip Mod GULLROWS) _

                   + (GULLCAWD \ 8)

            intDyp = (GULLCAHT \ 4) * (Ip \ GULLROWS) _

                   + (GULLCAHT \ 8)

            '

            '*描画パターンを乱数で

            Jp = Int(4 * Rnd + 1)

            '*パターン毎にベジェデータ設定

            Select Case Jp

                   Case 1: ReDim sngBDat(UBound(sngBBs1, 1), 1)

                    intDxp = intDxp - (GULLCAWD \ 16)

                   For Kp = LBound(sngBBs1, 1) To UBound(sngBBs1, 1)

                       sngBDat(Kp, 0) = sngBBs1(Kp, 0) + intDxp

                       sngBDat(Kp, 1) = sngBBs1(Kp, 1) + intDyp

                   Next Kp

                   Case 2: ReDim sngBDat(UBound(sngBBs2, 1), 1)

                   intDxp = intDxp + (GULLCAWD \ 16)

                   For Kp = LBound(sngBBs2, 1) To UBound(sngBBs2, 1)

                       sngBDat(Kp, 0) = sngBBs2(Kp, 0) + intDxp

                       sngBDat(Kp, 1) = sngBBs2(Kp, 1) + intDyp

                   Next Kp

                   Case 3: ReDim sngBDat(UBound(sngBBs3, 1), 1)

                   intDyp = intDyp + (GULLCAHT \ 16)

                   For Kp = LBound(sngBBs3, 1) To UBound(sngBBs3, 1)

                       sngBDat(Kp, 0) = sngBBs3(Kp, 0) + intDxp

                       sngBDat(Kp, 1) = sngBBs3(Kp, 1) + intDyp

                   Next Kp

                   Case 4: ReDim sngBDat(UBound(sngBBs4, 1), 1)

                   intDyp = intDyp - (GULLCAHT \ 16)

                   For Kp = LBound(sngBBs4, 1) To UBound(sngBBs4, 1)

                       sngBDat(Kp, 0) = sngBBs4(Kp, 0) + intDxp

                       sngBDat(Kp, 1) = sngBBs4(Kp, 1) + intDyp

                   Next Kp

          End Select

          '*ベジェデータ描画

          With .CanvasItems.AddCurve(sngBDat)

               .Fill.Visible = msoTrue

               .Fill.ForeColor.RGB = vbWhite '←背景色（かもめ）

               .Line.Visible = msoFalse

         End With

       Next Ip

    End With

    '*キャンバス解放

    Set shpCanv = Nothing

End Sub

補足

　乱数を使用しているので、実行の度に図柄が異なります。

蛇足

　作者のかかりつけの歯科医院の天井に描かれている「かもめ」の図柄を参照にしました。