【Word VBA】組亀甲文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 組亀甲文様描画マクロ() 

    Const SHELLEFT = 150　　　　　　　            '描画開始位置Ｘ

    Const SHELTOPP = 120 　　　　　　　　　　  '                  Ｙ

    Const SHELWIDT = 25                                  '台形(〔〕の一つ)幅

    Const SHELHEIG = 5 　　　　　　　　　　　  '台形(〔〕の一つ)高さ

    Const SHELCOLS = 8                                    '横描画数

    Const SHELROWS = 4                                   '縦描画数

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

    Dim Ip As Integer, Jp As Integer, Kp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intDan As Integer, lngCol As Long

    '

    lngCol = RGB(255, 99, 71) '←描画色

    For Jp = 0 To SHELROWS - 1

        For Ip = 0 To SHELCOLS - 1

            intCxp = SHELLEFT + (SHELWIDT * 1.4) * Ip

            intCyp = SHELTOPP + (SHELWIDT * 1.6) * Jp  _

                                          + (SHELWIDT * 0.8) * (Ip Mod 2)

            '*｜(右)描画

            intDxp = intCxp - SHELWIDT \ 2 + 4

            intDyp = intCyp - SHELWIDT \ 2

            intDan = 90: GoSub 台形描画_RTN

            '*｜(左)描画

            intDxp = intCxp - SHELWIDT \ 2 - 5

            intDyp = intCyp - SHELWIDT \ 2

            intDan = 270: GoSub 台形描画_RTN

            '*＼(上)描画

            intDxp = intCxp + SHELWIDT / 4 - SHELHEIG + 1

            intDyp = intCyp + SHELWIDT / 4 - 1

            intDan = 30: GoSub 台形描画_RTN

            '*＼(下)描画

            intDxp = intCxp + SHELWIDT / 4 - SHELHEIG - 4

            intDyp = intCyp + SHELWIDT / 2 - 1

            intDan = 210: GoSub 台形描画_RTN

            '*／(下)描画

            intDxp = intCxp - SHELWIDT \ 2 - SHELHEIG - 6

            intDyp = intCyp + SHELWIDT / 2 - 1

            intDan = 150: GoSub 台形描画_RTN

            '*／(上)描画

            intDxp = intCxp - SHELWIDT \ 2 - SHELHEIG - 10

            intDyp = intCyp + SHELWIDT / 4 - 1

            intDan = 330: GoSub 台形描画_RTN

        Next Ip

    Next Jp

    Exit Sub

    '=========================================

台形描画_RTN:

    With ActiveDocument.Shapes.AddShape(msoShapeTrapezoid, _

        intDxp + 0, intDyp + 0, SHELWIDT - 0, SHELHEIG)

         .Fill.Visible = True                                 '←塗りつぶし

         .Fill.ForeColor.RGB = lngCol

         .Line.Visible = True                               '←線

         .Line.ForeColor.RGB = lngCol

         .Rotation = intDan                                '←回転角

         .Adjustments(1) = 1 / Sqr(3)

    End With

    Return

End Sub

蛇足

小手先で、マクロでの描画位置を調整したので、ちょっと模様が雑になった。