【Word VBA】武田菱文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 武田菱文様描画マクロ()

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

    Const TKRHTOPP = 120 　　　'　　　　　　Ｙ

    '

    Const TKRHSMWD = 30 　　　'内側ひし形幅

    Const TKRHHPAW = 0.6 　　　'ひし形　高さ/幅

    Const TKRHSMGP = 3

    Const TKRHMDWD = TKRHSMWD * 3　　'中間ひし形幅

    Const TKRHOTWD = TKRHSMWD * 4　　'外側ひし形幅

    '

    Const TKRHMDWE = 4　　　　　'中間ひし形線の太さ

    Const TKRHOTWE = 6　　　　　'外側ひし形線の太さ

    '

    Const TKRHROWS = 5　　　　　'縦描画数

    Const TKRHCOLS = 2　　　　　'横描画数

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intHei As Integer

    Dim lngCol As Long

    '

    lngCol = vbBlue                    '←描画色

    For Jp = 0 To TKRHROWS - 1

         intCyp = TKRHTOPP + CInt((TKRHOTWD * TKRHHPAW) / 2) * Jp

        For Ip = 0 To TKRHCOLS - 1

            intCxp = TKRHLEFT + TKRHOTWD * Ip _

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

 　　　'*内側の４つのひし形

            intHei = CInt(TKRHSMWD * TKRHHPAW)

            For Kp = 0 To 3

                intDxp = intCxp + (TKRHSMWD / 2 + TKRHSMGP) _

                                * Choose(Kp + 1, 0, 1, 0, -1)

                intDyp = intCyp + (intHei / 2 + TKRHSMGP) _

                                * Choose(Kp + 1, -1, 0, 1, 0)

                With ActiveDocument.Shapes.AddShape(msoShapeDiamond, _

                    intDxp - TKRHSMWD / 2, intDyp - intHei / 2, _

                                       TKRHSMWD, intHei)

                    .Fill.ForeColor.RGB = lngCol

                    .Line.Visible = msoFalse

                End With

            Next Kp

 　　　'*中間のひし形

            intHei = CInt(TKRHMDWD * TKRHHPAW)

            With ActiveDocument.Shapes.AddShape(msoShapeDiamond, _

                 intCxp - TKRHMDWD / 2, intDyp - intHei / 2, _

                                     TKRHMDWD, intHei)

                .Fill.Visible = msoFalse

                .Line.ForeColor.RGB = lngCol

                .Line.Visible = msoTrue

                .Line.Weight = TKRHMDWE

            End With

 　　　'*外側のひし形

            intHei = CInt(TKRHOTWD * TKRHHPAW)

            With ActiveDocument.Shapes.AddShape(msoShapeDiamond, _

                 intCxp - TKRHOTWD / 2, intDyp - intHei / 2, _

                                     TKRHOTWD, intHei)

                .Fill.Visible = msoFalse

                .Line.ForeColor.RGB = lngCol

                .Line.Visible = msoTrue

                .Line.Weight = TKRHOTWE

            End With

        Next Ip

    Next Jp

End Sub