【Word VBA】ペイズリー柄描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Const PAISLEFT = -80　　　　   '描画開始位置Ｘ

Const PAISTOPP = 10 　　　　　'　　　　　　Ｙ

'

Const PAISCOLS = 5　　　　      '横/描画数

Const PAISROWS = 3 　　　　　 '縦/描画数

'

Const PAISVPIT = 45                 '横/描画間隔

Const PAISHPIT = 60                 '縦/描画間隔

Const PAISBZMG = 0.5               '描画倍率

'

Const PAISLNWT = 1.5　　　      '線の太さ

Const PAISLNCL = &H696969　  '線、塗りつぶしの色

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

Dim varShaNa(0 To 4) As Variant 'グループ化のための名前格納エリア

'

'

Public Sub ペイズリー柄描画マクロ() 

    Dim Ip As Integer, Jp As Integer

    Dim intDxp As Integer, intDyp As Integer, varBezi As Variant

    Dim sngBBs1() As Single, sngBBs2() As Single, sngBBs3() As Single

    Dim sngBBs4() As Single, sngBBs5() As Single

     '

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

    varBezi = Array(348.18, 204.57, 348.84, 205.69, 353.43, 204.37, 354.78, 205.55, 356.13, 206.72, 356.97, 210.04, 356.3, 211.62, 355.64, 213.2, 352.91, 214.86, 350.8, 215.02, 348.69, 215.19, 345.19, 214.19, 343.64, 212.61, 342.08, 211.03, 341.49, 207.99, 341.49, 205.53, 341.49, 203.08, 342.32, 200.24, 343.64, 197.88, 344.96, 195.51, 346.77, 193.24, 349.44, 191.33, 352.11, 189.42, 355.64, 187.86,  _

359.66, 186.4, 363.67, 184.94, 369.26, 184.49, 373.53, 182.57, 377.79, 180.66, 382.71, 178.37, 385.26, 174.9, 387.81, 171.44, 388.64, 165.73, 388.83, 161.76, 389.01, 157.79, 388.56, 154.43, 386.36, 151.08, 384.17, 147.73, 380.52, 143.63, 375.67, 141.67, 370.82, 139.7, 362.55, 138.64, 357.27, 139.27, 351.98, 139.9, 348.39, 141.93,  _

343.97, 145.44, 339.55, 148.95, 334.01, 155.46, 330.73, 160.33, 327.45, 165.2, 325.71, 170.13, 324.27, 174.68, 322.84, 179.22, 322.38, 182.61, 322.12, 187.59, 321.87, 192.58, 321.65, 199.64, 322.74, 204.61, 323.84, 209.57, 326.3, 214.17, 328.71, 217.39, 331.11, 220.61, 333.32, 222.51, 337.18, 223.95, 341.05, 225.38, 347.73, 227.05,  _

351.9, 226.01, 356.07, 224.98, 360.07, 220.6, 362.21, 217.73, 364.34, 214.86, 364.58, 211.33, 364.71, 208.78, 364.85, 206.23, 364.15, 204.16, 363.02, 202.42, 361.89, 200.68, 359.55, 198.76, 357.92, 198.32, 356.28, 197.88, 352.43, 197.79, 350.81, 198.83, 349.19,  _

199.88, 347.52, 203.45, 348.18, 204.57)

    Call ペイズリー柄描画マクロ_設定(varBezi, sngBBs1)

    '

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

    varBezi = Array(334.81, 211.24, 334.09, 210.2, 330.22, 202.87, 329.7, 197.73, 329.18, 192.59, 330.27, 185.96, 331.72, 180.4, 333.16, 174.84, 334.78, 169.39, 338.36, 164.39, 341.94, 159.39, 347.87, 153.12, 353.21, 150.41, 358.55, 147.7, 366.06, 146.91, 370.41, 148.12, 374.75, 149.33, 377.8, 154.42, 379.27, 157.66, 380.74, 160.9,  _

380.75, 164.88, 379.22, 167.57, 377.68, 170.26, 373.58, 172.19, 370.07, 173.81, 366.57, 175.43, 362.03, 175.85, 358.18, 177.3, 354.34, 178.76, 350.12, 180.58, 347.01, 182.53, 343.91, 184.47, 341.53, 186.86, 339.54, 188.96, 337.56, 191.06, 335.96, 192.74, 335.08,  _

195.12, 334.2, 197.51, 334.08, 201.31, 334.03, 204#, 333.99, 206.68, 335.54, 212.29, 334.81, 211.24)

    Call ペイズリー柄描画マクロ_設定(varBezi, sngBBs2)

    '

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

    varBezi = Array(362.12, 231.33, 361.68, 230.53, 356.28, 235.51, 352.25, 236.16, 348.22, 236.82, 342.74, 236.63, 337.95, 235.26, 333.16, 233.89, 327.28, 229.77, 323.51, 227.95, 319.73, 226.13, 317.87, 224.29, 315.29, 224.33, 312.72, 224.37, 309.7, 226.18, 308.05, 228.19, 306.4, 230.21, 305.15, 233.63, 305.39, 236.41, 305.63, 239.18, _ 307#, 242.45, 309.5, 244.86, 311.99, 247.28, 315.78, 249.97, 320.37, 250.9, 324.96, 251.83, 331.28, 252.07, 337.03, 250.42, 342.79, 248.77, 350.72, 244.18, 354.9, 241#, 359.09, 237.82, 362.57, 232.14, 362.12, 231.33)

    Call ペイズリー柄描画マクロ_設定(varBezi, sngBBs3)

    '

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

    varBezi = Array(342.04, 242.07, 342.74, 241.05, 336.67, 241.13, 333.76, 239.94, 330.84, 238.74, 327.17, 236.46, 324.56, 234.89, 321.96, 233.32, 320.27, 231.17, 318.15, 230.51, 316.03, 229.84, 312.93, 229.45, 311.86, 230.92, 310.78, 232.38, 310.57, 236.91, 311.7,  _

239.29, 312.83, 241.67, 315.65, 244.08, 318.63, 245.2, 321.61, 246.33, 325.69, 246.57, 329.59, 246.05, 333.49, 245.53, 341.35, 243.09, 342.04, 242.07)

    Call ペイズリー柄描画マクロ_設定(varBezi, sngBBs4)

    '

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

    varBezi = Array(341.02, 178.6, 342.2, 178.66, 347.64, 173.64, 350.93, 172#, 354.21, 170.36, 357.48, 169.73, 360.73, 168.74, 363.99, 167.75, 368.52, 167.47, 370.46, 166.05, 372.4, 164.64, 372.84, 161.77, 372.37, 160.23, 371.89, 158.69, 369.55, 157.46, 367.62, 156.79, 365.7, 156.13, 363.26, 155.84, 360.83, 156.23, 358.41, 156.61,  _

355.25, 157.78, 353.08, 159.12, 350.92, 160.45, 349.52, 162#, 347.85, 164.24, 346.18, 166.48, 344.98, 169.28, 343.84, 171.67, 342.7, 174.07, 339.84, 178.55, 341.02, 178.6)

    Call ペイズリー柄描画マクロ_設定(varBezi, sngBBs5)

    '

    '

    '*ペイズリー柄描画

    For Jp = 0 To PAISROWS - 1

        intDyp = PAISTOPP + PAISHPIT * Jp

        For Ip = 0 To PAISCOLS - 1

            intDxp = PAISLEFT + PAISVPIT * Ip

            '*ベジエ曲線データ表示

            Call ペイズリー柄描画マクロ_表示(sngBBs1, intDxp, intDyp, 0)

            Call ペイズリー柄描画マクロ_表示(sngBBs2, intDxp, intDyp, 1)

            Call ペイズリー柄描画マクロ_表示(sngBBs3, intDxp, intDyp, 2)

            Call ペイズリー柄描画マクロ_表示(sngBBs4, intDxp, intDyp, 3)

            Call ペイズリー柄描画マクロ_表示(sngBBs5, intDxp, intDyp, 4)

            'グループ化と、回転（無し or 180度）

            ActiveDocument.Shapes.Range(varShaNa).Group.Rotation = _

                     IIf(((Jp + Ip) Mod 2) = 0, 0, 180)

        Next Ip

    Next Jp

    '

    Selection.Collapse Direction:=wdCollapseStart '選択解除

End Sub

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Public Sub ペイズリー柄描画マクロ_設定(pvarBezi As Variant, psngBBas() As Single)

'

    Dim Ip As Integer

    '*ベジェ曲線、単精度実数配列に設定

    ReDim psngBBas(UBound(pvarBezi, 1) \ 2, 1)

    For Ip = LBound(psngBBas, 1) To UBound(psngBBas, 1)

        psngBBas(Ip, 0) = CSng(pvarBezi(Ip * 2 + 0)) * PAISBZMG

        psngBBas(Ip, 1) = CSng(pvarBezi(Ip * 2 + 1)) * PAISBZMG

    Next Ip

End Sub

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Public Sub ペイズリー柄描画マクロ_表示(psngBBas() As Single, _

           pintDxp As Integer, pintDyp As Integer, pintId As Integer)

'

    Dim Ip As Integer, sngBDat() As Single

    '

    '*ベジエ曲線データ位置設定

    ReDim sngBDat(UBound(psngBBas, 1), 1)

    For Ip = LBound(psngBBas, 1) To UBound(psngBBas, 1)

         sngBDat(Ip, 0) = psngBBas(Ip, 0) + pintDxp

         sngBDat(Ip, 1) = psngBBas(Ip, 1) + pintDyp

    Next Ip

    '

    '*ベジエ曲線データ表示

    With ActiveDocument.Shapes.AddCurve(sngBDat)

         '輪郭のみと塗りつぶしがある

         Select Case pintId

                Case 0, 1, 2: .Line.ForeColor.RGB = PAISLNCL

                              .Fill.Visible = msoFalse

                              .Line.Visible = msoTrue

                Case 3, 4: .Fill.ForeColor.RGB = PAISLNCL

                              .Fill.Visible = msoTrue

                              .Line.Visible = msoFalse

         End Select

         .Line.Weight = PAISLNWT '線の太さ

         varShaNa(pintId) = .Name 'グループ化の名前保存

    End With

End Sub