【Word VBA】観世水模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 観世水模様描画マクロ()

    Const KNZWLEFT = 100　　'描画開始位置Ｘ

    Const KNZWTOPP = 100　　'　　　　　　Ｙ

    '

    Const KNZWCOLS = 5　　　'横/描画数

    Const KNZWROWS = 5　　　'縦/描画数

    '

    Const KNZWSWAN = 30　　　'渦巻描画刻み角

    Const KNZWSWMG = 0.5　　'渦巻描画　係数

    Const KNZWOCWD = (20 * KNZWSWMG) 　'円弧幅

    Const KNZWOCPT = (8 * KNZWSWMG) 　　'円弧間隔

    Const KNZWOCCN = 4　　　'円弧の数

    Const KNZWOCAG = 0.1　　'円弧の厚み

    Const KNZWOCHT = 1.1　　'(円弧/渦巻)の高さ

    Const KNZWHSPC = 1.25　　'(行/円弧)の高さ

    '

    Const KNZWLNWE = 0.75　　'渦巻線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intDvp As Integer, intDhp As Integer

    Dim intExp As Integer, intEyp As Integer

    Dim intEHt As Integer, intEPt As Integer

    Dim lngCol As Long

    Dim sngBFp(45, 1) As Single, sngBFm(1, 1) As Single

    Dim sngBRd As Single, sngSit As Single

    '

    '*渦巻描画データ作成

    sngBRd = ((4 * Atn(1)) / 180) * KNZWSWAN

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

        sngSit = sngBRd * Kp

        sngBFp(Kp, 0) = sngSit * Cos(sngSit) * KNZWSWMG

        sngBFp(Kp, 1) = sngSit * Sin(sngSit) * KNZWSWMG

        'サイズ（上下左右）を取得

        If Kp = LBound(sngBFp, 1) Then

           sngBFm(0, 0) = sngBFp(Kp, 0): sngBFm(0, 1) = sngBFp(Kp, 1)

           sngBFm(1, 0) = sngBFp(Kp, 0): sngBFm(1, 1) = sngBFp(Kp, 0)

        Else

           If sngBFm(1, 0) > sngBFp(Kp, 0) Then _

                             sngBFm(1, 0) = sngBFp(Kp, 0)　　   '←左

           If sngBFm(0, 0) < sngBFp(Kp, 0) Then _

                             sngBFm(0, 0) = sngBFp(Kp, 0)　　   '←右

           If sngBFm(1, 1) > sngBFp(Kp, 1) Then _

                             sngBFm(1, 1) = sngBFp(Kp, 1) 　　　'←上

           If sngBFm(0, 1) < sngBFp(Kp, 1) Then _

                             sngBFm(0, 1) = sngBFp(Kp, 1) 　　　'←下

        End If

    Next Kp

    '

    lngCol = RGB(0, 0, 205)　　　　　　                  '←線色

    intEHt = (sngBFm(0, 1) - sngBFm(1, 1)) * KNZWOCHT

    intDhp = intEHt * KNZWHSPC 　　　　　　　　　'←行高

    intDvp = (sngBFm(0, 0) - sngBFm(1, 0)) _

           + KNZWOCPT * (KNZWOCCN + 1) * 2　      '←桁幅

    For Jp = 0 To KNZWROWS - 1

        intDyp = KNZWTOPP + intDhp * Jp

        For Ip = 0 To KNZWCOLS - IIf((Jp Mod 2) = 0, 1, 2)

            intDxp = KNZWLEFT + intDvp * Ip _

                   + (intDvp / 2) * (Jp Mod 2)

            '*渦巻描画

            With ActiveDocument.Shapes.BuildFreeform(msoEditingAuto, _

                 sngBFp(LBound(sngBFp, 1), 0) + intDxp, _

                 sngBFp(LBound(sngBFp, 1), 1) + intDyp)

                 For Kp = LBound(sngBFp, 1) + 1 To UBound(sngBFp, 1)

                    .AddNodes msoSegmentCurve, msoEditingAuto, _

                      sngBFp(Kp, 0) + intDxp, sngBFp(Kp, 1) + intDyp

                 Next Kp

                 With .ConvertToShape

                      .Fill.Visible = msoFalse

                      .Line.Visible = msoTrue

                      .Line.ForeColor.RGB = lngCol

                      .Line.Weight = KNZWLNWE

                 End With

           End With

           '*左右の円弧（三日月）描画

           intEyp = intDyp + sngBFm(1, 1)

           For Kp = 1 To KNZWOCCN

               intEPt = KNZWOCPT * Kp

               For Lp = 0 To 1

                   intExp = intDxp + _

                   IIf(Lp = 0, sngBFm(1, 0) - intEPt, _

                   sngBFm(0, 0) - KNZWOCWD + intEPt + KNZWOCPT / 2)

                   With ActiveDocument.Shapes.AddShape( _

                        msoShapeMoon, intExp, intEyp, _

                        KNZWOCWD, intEHt)

                       .Fill.Visible = msoTrue

                       .Fill.ForeColor.RGB = lngCol

                       .Line.Visible = msoFalse

                       .Adjustments(1) = KNZWOCAG

                       If Lp = 1 Then .Flip msoFlipHorizontal

                  End With

              Next Lp

           Next Kp

        Next Ip

    Next Jp

End Sub