【Word VBA】籠目文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 籠目文様描画マクロ()

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

    Const RETITOPP = 80 　　　　　　　　　'　　            Ｙ

    Const RETIWIDT = 25 　　　　　　　　　'平行四辺形幅

    Const RETIHEIG = 5 　　　　　　　　　   '              高さ

    Const RETICOLS = 7                               '横並び数

    Const RETIROWS = 5                              '縦並び数

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

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

    Dim dblRd As Double

    Dim intDxp As Integer, intDyp As Integer

    Dim intDai As Integer, lngCol As Long

    '

    dblRd = (4 * Atn(1)) / 180

    '

    lngCol = RGB(34, 139, 34) '←塗りつぶし色(緑)

    intDai = CInt(RETIWIDT / Sqr(3)) '←対角線長さ

    For Jp = 0 To RETIROWS - 1

        intDyp = RETITOPP + _

        (RETIWIDT + RETIHEIG) * Sin(60 * dblRd) * Jp - 2

        intDxp = RETILEFT + _

       IIf((Jp Mod 2) = 0, 0, 1) * ((RETIWIDT + RETIHEIG) / 2)

        For Ip = 0 To RETICOLS - 1

            For Kp = 1 To 3                         '←1:'－' 2:'／' 3'＼'

      With ActiveDocument.Shapes.AddShape(msoShapeParallelogram, _

                     Choose(Kp, intDxp, intDxp - intDai, _

                           intDxp + intDai / 2), _

                     Choose(Kp, intDyp, intDyp, _

                           intDyp + RETIHEIG + intDai / 2), _

                     RETIWIDT, RETIHEIG)

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

                     .Fill.ForeColor.RGB = lngCol

                     .Line.Visible = msoTrue '←線

                     .Line.ForeColor.RGB = vbWhite '←隙間にする。

                     .Line.Weight = 1

                     '

                     .Rotation = Choose(Kp, 0, -60, 60)

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

                  End With

            Next Kp

            intDxp = intDxp + RETIWIDT + CInt(RETIHEIG / Sqr(3)) + 1

        Next Ip

    Next Jp

End Sub