【Word VBA】つた家紋描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub つた家紋描画マクロ()

    Const IVYSLEFT = 150　　        '*描画開始位置Ｘ

    Const IVYSTOPP = 150 　　　　'　  　　　　　Ｙ

    '

    Const IVYSYOPS = 180             '*円弧描画Ｙ位置補正値

    Const IVYSCRAD = 8                '*真ん中の丸半径

    Const IVYSLNWE = 4               '*線の太さ

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

    Dim Ip As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim lngCol(1) As Long

    Dim sngBBas() As Single, sngBDat() As Single

    Dim varBezi As Variant

    Dim sngABas() As Single, sngADat() As Single

    Dim varArcL As Variant

    '

    '*外形輪郭ベジェ曲線データ

    varBezi = Array(70.3, -7.46, 70.38, -30.21, 70.51, -33.6, 70.99, -39.8, 71.47, -46#, 72.28, -43.35, 73.2, -44.66, 74.12, -45.97, _

    76.03, -47.13, 77.9, -48#, 79.78, -48.87, 82.25, -49.75, 84.45, -49.87, 86.65, -49.99, 88.9, -48.04, 91.11, -48.73, 93.32, -49.41, 95.15, -52.59, 97.71, -53.99, 100.27, -55.38, 102.91, -57.05, 106.48, -57.11, 110.04, -57.17, 115.73, -55.95, 119.11, -54.32, 122.48, -52.7, 124.85, -49.63, 126.73, -47.36, 128.61, -45.1, 128.81, -42.17, 130.38, -40.73, 131.95, -39.29, 134#, -39.75, 136.14, -38.71, 138.28, -37.66, 140.87, -36.67, 143.23, -34.46, 145.58, -32.26, _

148.91, -28.58, 150.26, -25.46, 151.61, -22.34, 151.39, -18.29, 151.33, -15.75, 151.27, -13.21, 148.82, -12.14, 149.91, -10.22, 151#, -8.31, 155.79, -6.44, 157.87, -4.27, 159.95, -2.1, 161.42, -0.09, 162.4, 2.78, 163.38, 5.65, 162.81, 10.4, 163.76, 12.94, 164.7, 15.48, 166.81, 15.66, 168.06, 18.02, 169.32, 20.38, 171.14, 23.7, 171.28, 27.09, 171.43, 30.49, 170.31, 35.53, 168.94, 38.39, 167.56, 41.26, 164.51, 41.97, 163.04, 44.28, 161.58, 46.58, 161.41, 49.86, 160.16, 52.24, 158.91, 54.62, 157.66, 56.94, 155.54, 58.55, 153.42, 60.16, 150.05, 61.38, 147.44, 61.9, 144.82, 62.43, _

142.03, 62#, 139.87, 61.7, 137.71, 61.39, 136.09, 59.59, 134.47, 60.08, 132.85, 60.57, 131.84, 63.38, 130.16, 64.61, 128.47, 65.83, 126.27, 67.04, 124.35, 67.44, 122.44, 67.84, 119.66, 67.16, 118.65, 67.01, 117.63, 66.87, 118.8, 66.34, 118.26, 66.58, 117.71, 66.83, 116.07, 67.6, 115.39, 68.48, 114.72, 69.36, 114.87, 71.39, 114.05, 73#, 113.22, 74.61, 111.97, 76.47, 110.46, 78.13, 108.95, 79.8, 105.89, 81.36, 104.99, 82.99, 104.09, 84.62, 105.32, 86.16, 105.08, 87.91, 104.85, 89.67, 104.36, 91.9, 103.57, 93.52, 102.79, 95.14, 101.85, 96.41, 100.39, 97.63, 98.93, 98.86, _

96.97, 100.32, 94.81, 100.88, 92.64, 101.44, 89.99, 99.91, 87.38, 101#, 84.78, 102.1, 81.87, 106.06, 79.19, 107.46, 76.52, 108.86, 73.46, 109.38, 71.35, 109.43, 69.24, 109.48, 66.4, 109.43, 66.55, 107.75, 66.71, 106.08, 69.86, 115.87, 70.48, 96.67, 71.11, 77.47, 70.21, 15.28, 70.3, -7.46)

    '*葉脈円弧描画データ

    varArcL = Array( _

      -0.25, 165.05, 92.75, 40.6, -164.61, -16.21, 353.11, _

     2.3, 140.95, 61.55, 40.3, -164.85, -8.64, 311.46, _

     11.55, 146.3, 55.8, 36.3, -156.03, -5.4, 318.34, _

     24.15, 150.6, 49.6, 28.6, -172.45, -6.85, 342.85, _

     30.9, 156.55, 44.4, 26.1, -156.03, -4.1, 345.53, _

     -25.9, 196.4, 122.05, 71.8, -165.04, -36.25, 41.97, _

     7.55, 179.4, 103.75, 66.05, -165.04, -52.39, 20.17, _

     20.45, 190.9, 91.55, 50.1, -173.88, -50.49, 32.38, _

     24.55, 198.55, 80.3, 48.9, -166.97, -55.29, 38.91, _

     11.65, 215.65, 103.75, 62.2, -166.37, -100.63, 62.66, _

     33.95, 187.25, 93.95, 45.2, 63.56, 144.57, 56.3, _

     29.7, 182#, 75.55, 45.75, 40.52, 144.57, 60.84, _

     16.3, 191#, 86.1, 43.2, 40.84, 161.8, 56.3, _

     -52.6, 207.65, 122.7, 76.55, -167.8, -69.48, 72.67, _

     -57.55, 210.05, 109.45, 81.6, -167.8, -79.17, 83.3, _

     -61.3, 221.3, 107.25, 76.5, -165.62, -80.97, 86.37, _

     -51.5, 243#, 94.95, 49.95, -178.74, -90.16, 95.37, _

     -47.5, 250.15, 82.9, 35.5, -169.26, -69.48, 90#, _

     4.15, 187.1, 110.4, 48.8, 157.53, 165.02, 46.73)

    '

    '*ベジェ曲線データ設定

    ReDim sngBBas(UBound(varBezi, 1) \ 2, 1)

    ReDim sngBDat(UBound(varBezi, 1) \ 2, 1)

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

        sngBBas(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) - 70.3

        sngBBas(Kp, 1) = CSng(varBezi(Kp * 2 + 1))

    Next Kp

    '

    '*円弧描画データ設定

    ReDim sngABas(18, 6), sngADat(18, 6)

    For Kp = 0 To 18

        For Ip = 0 To 6

            sngABas(Kp, Ip) = CSng(varArcL(Kp * 7 + Ip))

        Next Ip

        sngABas(Kp, 0) = sngABas(Kp, 0) + 0

    Next Kp

    '

    intDxp = IVYSLEFT: intDyp = IVYSTOPP

    lngCol(0) = vbWhite                  '←線の色

    lngCol(1) = RGB(0, 0, 128)        '←塗りつぶし色

    '

    For Lp = 0 To 1                          '0:右側　1:左側

        '*ベジエ曲線位置設定

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

            sngBDat(Kp, 0) = _

            IIf(Lp = 0, sngBBas(Kp, 0) + intDxp, intDxp - sngBBas(Kp, 0))

            sngBDat(Kp, 1) = sngBBas(Kp, 1) + intDyp

        Next Kp

        '

        '*ベジエ曲線描画

        With ActiveDocument.Shapes.AddCurve(sngBDat)

             .Line.Visible = msoFalse

             .Fill.Visible = msoTrue

             .Fill.ForeColor = lngCol(1)

        End With

        '

        '*円弧描画

        For Kp = 0 To 18

            With ActiveDocument.Shapes.AddShape(msoShapeArc, _

                IIf(Lp = 0, sngABas(Kp, 0) + intDxp, _

                    (intDxp + 0) - sngABas(Kp, 0) - sngABas(Kp, 2)), _

                sngABas(Kp, 1) + intDyp - IVYSYOPS, _

                sngABas(Kp, 2), sngABas(Kp, 3))

               .Adjustments(1) = sngABas(Kp, 4)

               .Adjustments(2) = sngABas(Kp, 5)

               .Rotation = sngABas(Kp, 6)

               .Line.ForeColor = lngCol(0)

               .Line.Weight = IVYSLNWE

               If Lp = 1 Then .Flip msoFlipHorizontal

           End With

        Next Kp

    Next Lp '

    '

    '*中心線描画

    With ActiveDocument.Shapes.AddLine( _

         intDxp + 0, intDyp - 45, _

         intDxp + 0, intDyp + 100).Line

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

            .Weight = IVYSLNWE                '←線の太さ

            .DashStyle = msoLineSolid        '←線のスタイル

   End With

   '

   '中心の丸描画

   With ActiveDocument.Shapes.AddShape(msoShapeOval, _

       intDxp - IVYSCRAD, intDyp - IVYSCRAD, _

       IVYSCRAD * 2, IVYSCRAD * 2)

       .Fill.Visible = msoTrue

       .Fill.ForeColor.RGB = lngCol(1)

       .Line.Visible = msoTrue

       .Line.ForeColor.RGB = lngCol(0)

      .Line.Weight = IVYSLNWE

   End With

End Sub

蛇足

　つた家紋は、作者の家の家紋でもある。