【Word VBA】古銭風模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 古銭風模様描画マクロ()

    Const ECOILEFT = 120                    '描画開始位置Ｘ

    Const ECOITOPP = 100                   '　　　　　　Ｙ

    '

    Const ECOICSIZ = 60                      '古銭のサイズ

    Const ECOIOTWE = 2                      '外形線の太さ

    Const ECOIMDWE = 2

    Const ECOISMLN = (ECOIOTWE + ECOIMDWE - 1)

    Const ECOIHSIZ = 18                      '穴の大きさ

    Const ECOIHRPS = (ECOICSIZ - ECOIHSIZ) / 2

    Const ECOIVSPC = 10                     '横の間隔

    Const ECOIHSPC = 10                     '縦の間隔

    '

    Const ECOICOLS = 3                       '横描画数

    Const ECOIROWS = 2                     '縦描画数

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp As Integer, intEyp As Integer

    Dim lngCol(3) As Long, strNam(4) As String

   '

    lngCol(0) = RGB(184, 134, 11)               '←描画色

    lngCol(1) = RGB(218, 165, 32)

    '

    strNam(0) = "野": strNam(2) = "口"        '←描画文字

    strNam(1) = "英": strNam(3) = "世"

    For Jp = 0 To ECOIROWS - 1

        intDyp = ECOITOPP _

               + (ECOICSIZ + ECOIHSPC) * Jp

        For Ip = 0 To ECOICOLS - 1

            intDxp = ECOILEFT _

                   + (ECOICSIZ + ECOIHSPC) * Ip

            '*円の部分を描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                intDxp, intDyp, ECOICSIZ, ECOICSIZ)

                .Fill.Visible = msoFalse

                .Line.ForeColor.RGB = lngCol(0)

                .Line.Weight = ECOIOTWE

            End With

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                intDxp + ECOIOTWE, intDyp + ECOIOTWE, _

                 ECOICSIZ - ECOIOTWE * 2, ECOICSIZ - ECOIOTWE * 2)

                .Fill.Visible = msoFalse

                .Line.ForeColor.RGB = lngCol(1)

                .Line.Weight = ECOIMDWE

            End With

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                intDxp + ECOISMLN, intDyp + ECOISMLN, _

                 ECOICSIZ - ECOISMLN * 2, ECOICSIZ - ECOISMLN * 2)

                .Fill.ForeColor.RGB = lngCol(0)

                .Fill.Visible = msoTrue

                .Line.Visible = msoFalse

            End With

            '*四角い穴の部分を描画

            With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _

                intDxp + ECOIHRPS - ECOIOTWE, _

                intDyp + ECOIHRPS - ECOIOTWE, _

                     ECOIHSIZ + ECOIOTWE * 2, _

                     ECOIHSIZ + ECOIOTWE * 2)

                .Fill.Visible = msoFalse

                .Line.ForeColor.RGB = lngCol(1)

                .Line.Weight = ECOIOTWE

            End With

            With ActiveDocument.Shapes.AddShape(msoShapeRectangle, _

                intDxp + ECOIHRPS, _

                intDyp + ECOIHRPS, _

                     ECOIHSIZ, ECOIHSIZ)

                .Fill.ForeColor.RGB = vbWhite

                .Fill.Visible = msoTrue

                .Line.Visible = msoFalse

            End With

            '*古銭の文字を描画

            For Kp = 1 To 4

                intExp = intDxp _

                + Choose(Kp, ECOICSIZ / 2 - 8, _

                  ECOICSIZ - 17, ECOICSIZ / 2 - 8, 3)

                intEyp = intDyp _

                + Choose(Kp, 0 + 5, ECOICSIZ / 2 - 8, _

                  ECOICSIZ - 17, ECOICSIZ / 2 - 8)

                With ActiveDocument.Shapes.AddTextbox( _

                     msoTextOrientationHorizontal, _

                     intExp, intEyp, ECOICSIZ, ECOICSIZ)

                     With .TextFrame

                          .MarginLeft = 0

                          .MarginTop = 0

                          .AutoSize = True

                          With .TextRange

                               .Font.Name = "Ｃ＆Ｇ半古印"

                               .Font.Size = 14

                               .Font.Bold = True

                               .Font.ColorIndex = wdGray25

                               .Text = strNam(Kp - 1)

                               .Paragraphs.LineSpacing = 14

                               .Paragraphs.LineSpacingRule = _

                               wdLineSpaceExactly

                          End With

                    End With

                 .Fill.Visible = False

                 .Line.Visible = False

                End With

            Next Kp

        Next Ip

    Next Jp

End Sub

《蛇足》

千円札が紙幣で無く、古銭だったらということで作成してみた。

もっとも、今の時代、三途の川の渡し賃が６千円ではないだろうが、それはどうであれ、昨今、三途の川は大混雑なような気がする。