【Word VBA】足跡描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 足跡描画マクロ()

    Const FTPRLFTL = 120             '左足-描画規準位置Ｘ

    Const FTPRLFTR = 200             '右足-描画規準位置Ｘ

    Const FTPRTOPL = 180            '左足-描画規準位置Ｙ

    Const FTPRTOPR = 230            '右足-描画規準位置Ｙ

    Const BEZIMAGN = 0.5            'ベジェ曲線データ倍率

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

    Dim Ip As Integer, Jp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intRad As Integer, intFht As Integer

    Dim varBez As Variant, lngCol As Long

    Dim sngBas(12, 1) As Single, sngDat(12, 1) As Single

    Dim sngRnd As Single, sngSit As Single

    '

    'ベジェ曲線データ（足の裏）設定

    varBez = Array(45, 92, 92, 50, 37, -5, 46, -56, 47, -101, -24, _

                 -136, -18, -58, 14, 35, -37, 2, -46, 77, -41, _

                 132, 12, 125, 45, 92)

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

        sngBas(Ip, 0) = CSng(varBez(Ip * 2 + 0)) * BEZIMAGN

        sngBas(Ip, 1) = CSng(varBez(Ip * 2 + 1)) * BEZIMAGN

    Next Ip

    '

    lngCol = RGB(105, 105, 105) '←塗りつぶし色

    sngRnd = (4 * Atn(1)) / 180

    '

    For Jp = 1 To 2 '1=左足, 2=右足

        intDxp = Choose(Jp, FTPRLFTL, FTPRLFTR)

        intDyp = Choose(Jp, FTPRTOPL, FTPRTOPR)

        '*ベジェ描画位置設定

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

            sngDat(Ip, 0) = Choose(Jp, -1, 1) _

                               * sngBas(Ip, 0) + intDxp

            sngDat(Ip, 1) = -1 * sngBas(Ip, 1) + intDyp

        Next Ip

        '*ベジェ描画（足の裏）

        With ActiveDocument.Shapes.AddCurve(sngDat)

            .Fill.Visible = msoTrue

            .Fill.ForeColor.RGB = lngCol

            .Line.Visible = msoFalse

        End With

        '

        '*楕円描画（足の指/親指(1)から）↓距離は基準値から

        intRad = CInt(Sqr(sngBas(10, 0) ^ 2 + sngBas(10, 1) ^ 2)) - 15

        For Ip = 1 To 5

            sngSit = sngRnd * IIf(Jp = 1, -55 - Ip * 15, -110 + Ip * 15)

            intFht = Choose(Ip, 20, 15, 12, 12, 12) 　　　　'指の長さ

            '*楕円描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                 intRad * Cos(sngSit) + intDxp + IIf(Jp = 1, 0, -15), _

                 intRad * Sin(sngSit) + intDyp + IIf(Jp = 1, -6, -8) _

                                      - intFht, _

                 Choose(Ip, 12, 10, 8, 8, 8), intFht)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol      '←塗りつぶし色

                .Line.Visible = msoFalse

                If Ip = 1 Then                        '親指だけを傾ける

                   .Rotation = IIf(Jp = 1, 8, -8)

                End If

            End With

        Next Ip

    Next Jp

End Sub