【Word VBA】六つ手卍文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 六つ手卍文様描画マクロ()

    Const SIXHLEFT = 160　　　　　        '描画開始位置Ｘ

    Const SIXHTOPP = 80 　　　　　　　  '　　　　　　Ｙ

    '

    Const SIZHMGNI = 10                        'ポリライン描画倍率

    '

    Const SIXHCOLS = 7                          '横描画数

    Const SIXHROWS = 4                        '縦描画数

    Const SIXHLNWE = 2                        '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intMxp As Integer, intMyp As Integer

    Dim sngBas(9, 1), sngDat(9, 1) As Single

    Dim sngTmp(1, 9, 1) As Single, dblSit As Double

    Dim lngCol As Long

    '

    '*ポリライン元データ

    sngBas(0, 0) = 0: sngBas(0, 1) = 0

    sngBas(1, 0) = 2: sngBas(1, 1) = 0:

    sngBas(2, 0) = 3: sngBas(2, 1) = Sqr(3):

    sngBas(3, 0) = 5: sngBas(3, 1) = Sqr(3):

    sngBas(4, 0) = 4: sngBas(4, 1) = Sqr(3) * 2:

    sngBas(5, 0) = 2: sngBas(5, 1) = Sqr(3) * 2:

    sngBas(6, 0) = 1: sngBas(6, 1) = Sqr(3) * 3:

    sngBas(7, 0) = 0: sngBas(7, 1) = Sqr(3) * 2:

    sngBas(8, 0) = 1: sngBas(8, 1) = Sqr(3) * 1:

    sngBas(9, 0) = 0: sngBas(9, 1) = 0

    '*描画ポリラインデータ作成(正・逆)

    For Jp = 0 To 1

        dblSit = (((4 * Atn(1)) / 180) * 300) * Jp _

                  - Atn(Sqr(3) / 5)

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

            sngTmp(Jp, Kp, 0) = (sngBas(Kp, 0) * Cos(dblSit) _

                      - sngBas(Kp, 1) * Sin(dblSit)) * SIZHMGNI

            sngTmp(Jp, Kp, 1) = (sngBas(Kp, 0) * Sin(dblSit) _

                      + sngBas(Kp, 1) * Cos(dblSit)) * SIZHMGNI

        Next Kp

    Next Jp

    '

    lngCol = RGB(153, 50, 204)                             '←線色

    intMxp = SIXHLEFT: intMyp = SIXHTOPP

    For Jp = 0 To SIXHROWS - 1

        sngDat(3, 0) = intMxp: sngDat(3, 1) = intMyp

        For Ip = 0 To SIXHCOLS - 1

            If (Ip Mod 2) = 0 Then

               intDxp = sngDat(3, 0): intDyp = sngDat(3, 1): Lp = 0

            Else

               intDxp = sngDat(6, 0): intDyp = sngDat(6, 1): Lp = 1

            End If

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

                sngDat(Kp, 0) = sngTmp(Lp, Kp, 0) + intDxp

                sngDat(Kp, 1) = sngTmp(Lp, Kp, 1) + intDyp

            Next Kp

            'ポリライン（１ピース）描画

            With ActiveDocument.Shapes.AddPolyline(sngDat)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = lngCol                 '←線色

                .Line.Weight = SIXHLNWE              '←線の太さ

            End With

            '

            If Ip = 0 Then '次行の先頭位置記憶

               intMxp = sngDat(0, 0) + (sngDat(6, 0) - sngDat(3, 0))

               intMyp = sngDat(0, 1) + (sngDat(6, 1) - sngDat(3, 1))

            End If

       Next Ip

   Next Jp

End Sub