【Word VBA】お椀とお箸描画マクロ▽ソースコード

Public Sub お椀とお箸描画マクロ()

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

    Const BOWLTOPP = 100　　'　　　　　　Ｙ

　　'

    Const BOWLCOLS = 6 　　'横/描画数

    Const BOWLROWS = 5 　　'縦/描画数

　　'

    Const BOWLLNWE = 0.75　 '線の太さ

　　'

    Const BOWLFMMG = 2 　　'お椀の描画倍率

    Const BOWLPLMG = 2 　　'お箸の描画倍率

　　'

    Const BOWLSTVP = (6 * BOWLFMMG) 　　'箸の位置Ｘ

    Const BOWLSTHP = (8 * BOWLFMMG) 　　'　　　　Ｙ

    Const BOWLSTGP = (2 * BOWLPLMG) 　　'箸の間隔

　　'

    Const BOWLVPIT = (20 * BOWLPLMG)　　'横-間隔

    Const BOWLHPIT = (15 * BOWLFMMG)　　'縦-間隔

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim sngFmP() As Single, varFmP As Variant

    Dim sngPBs() As Single, varPlP As Variant

    Dim sngPDt() As Single

    Dim lngCol(3) As Long

　　'

　　'*お椀データ

    varFmP = Array(0, 0, 0, 1.8, 3.15, 5.8, 4.73, 6.8, 4.73, 7.8, 7.95, _

        7.8, 7.95, 6.8, 9.54, 5.8, 12.73, 1.8, 12.73, 0, 1.54, 0, 0, 0)

　　'*お箸データ

    varPlP = Array(-9#, 0.25, -9#, -0.25, 9#, -0.5, 9#, 0.5, -9#, 0.25)

　　'

　　'*お椀データ設定

    ReDim sngFmP((UBound(varFmP, 1) - 1) \ 2, 1)

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

        sngFmP(Kp, 0) = CSng(varFmP(Kp * 2 + 0)) * BOWLFMMG

        sngFmP(Kp, 1) = CSng(varFmP(Kp * 2 + 1)) * BOWLFMMG

    Next Kp

　　'*お箸データ設定

    ReDim sngPBs((UBound(varPlP, 1) - 1) \ 2, 1)

    ReDim sngPDt((UBound(varPlP, 1) - 1) \ 2, 1)

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

        sngPBs(Kp, 0) = CSng(varPlP(Kp * 2 + 0)) * BOWLPLMG

        sngPBs(Kp, 1) = CSng(varPlP(Kp * 2 + 1)) * BOWLPLMG

    Next Kp

    lngCol(0) = vbBlack 　　'←輪郭の色

    lngCol(1) = RGB(139, 0, 0) 　　'←お椀の色

    lngCol(2) = RGB(128, 0, 0) 　　'←お箸の色

    lngCol(3) = vbWhite

　　'

    For Jp = 0 To BOWLROWS - 1

        intDyp = BOWLTOPP + BOWLHPIT * Jp

        For Ip = 0 To BOWLCOLS - 1 - (Jp Mod 2)

            intDxp = BOWLLEFT + BOWLVPIT * Ip _

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

        　　'*お椀描画

            With ActiveDocument.Shapes.BuildFreeform( _

                 msoEditingAuto, _

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

                sngFmP(LBound(sngFmP, 1), 1) + intDyp)

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

                   .AddNodes IIf(Kp = 2 Or Kp = 7, _

                        msoSegmentCurve, msoSegmentLine), _

                        msoEditingAuto, _

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

                Next Kp

                With .ConvertToShape

                     .Fill.Visible = msoTrue

                     .Fill.ForeColor.RGB = _

                      IIf((Jp Mod 2) = 0, lngCol(1), lngCol(3))

                      .Line.Visible = msoTrue

                     .Line.ForeColor.RGB = lngCol(0)

                     .Line.Weight = BOWLLNWE

               End With

          End With

      　　'*お箸描画

          For Lp = 1 To 2

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

                  sngPDt(Kp, 0) = sngPBs(Kp, 0) + intDxp _

                                + BOWLSTVP

                  sngPDt(Kp, 1) = sngPBs(Kp, 1) + intDyp _

                                + BOWLSTHP + BOWLSTGP * Lp

              Next Kp

              With ActiveDocument.Shapes.AddPolyline(sngPDt)

                  .Fill.Visible = msoTrue

                  .Fill.ForeColor.RGB = _

                       IIf((Jp Mod 2) = 0, lngCol(2), lngCol(3))

                  .Line.Visible = msoTrue

                  .Line.ForeColor.RGB = lngCol(0) '←線の色

                  .Line.Weight = BOWLLNWE

                  If Ip = 0 And (Jp Mod 2) = 0 Then _

                     .Flip msoFlipHorizontal 　　'←左端、左利き

              End With

          Next Lp

        Next Ip

    Next Jp

End Sub