【Word VBA】扇子描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 扇子描画マクロ() 

    Const FFANCXP = 230 　　　　'扇子要位置

    Const FFANCYP = 210

    Const FFANHRD = 150　　　    '扇子外径

    Const FFANLRD = 50 　　　　  '扇子内径

    Const FFANBWD = 2                '扇子骨幅

    '

    Const FFANHVS = 6                 '扇外側谷の差

    Const FFANLVS = 3                 '扇内側谷の差

    '

    Const FFANOCN = 16              '扇の枚数 ×２

    Const FFANOAN = 100            '開いた角度

    '

    Const FFANERV = 0.8             '端の骨の位置補正

    Const FFANESZ = 2.8             '端の骨の長さ補正

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim lngCol(3) As Long

    Dim sngPly(4, 1) As Single, sngRad(3) As Single

    Dim sngAng(1) As Single, sngPan As Single

    Dim sngRdn As Single

    '

    lngCol(0) = vbBlack '←輪郭色

    lngCol(1) = vbYellow '←扇の色

    lngCol(2) = RGB(255, 215, 0) '←扇の色

    lngCol(3) = RGB(210, 180, 140) '←骨の色

    '

    sngRdn = (4 * Atn(1)) / 180: sngPan = FFANOAN / FFANOCN

    '*骨描画

    For Ip = FFANOCN / 2 - 1 To 0 Step -1

        sngAng(0) = FFANOAN - 178 - ((Ip + 1) * 2) * sngPan

        sngAng(1) = sngRdn * sngAng(0)

        sngPly(0, 0) = (FFANLRD / 2) * Cos(sngAng(1)) _

                  - (FFANLRD / 2) * Sin(sngAng(1)) + FFANCXP

        sngPly(0, 1) = (FFANLRD / 2) * Sin(sngAng(1)) _

                  + (FFANLRD / 2) * Cos(sngAng(1)) + FFANCYP

        '

        With ActiveDocument.Shapes.AddShape(  _

      msoShapeFlowchartTerminator,  _

             sngPly(0, 0) - FFANBWD \ 2, sngPly(0, 1) - FFANLRD, _

                            FFANBWD, FFANLRD * 2)

            .Fill.Visible = msoTrue

            .Fill.ForeColor.RGB = lngCol(3)

            .Line.Visible = msoTrue

            .Line.ForeColor.RGB = lngCol(0)

            .Rotation = sngAng(0) - 45

        End With

     Next Ip

    '*内側扇描画

    For Ip = 2 To FFANOCN - 3

        sngAng(0) = sngRdn * ((Ip + 0) * sngPan - (90 + FFANOAN \ 2))

        sngAng(1) = sngRdn * ((Ip + 1) * sngPan - (90 + FFANOAN \ 2))

        sngRad(0) = FFANHRD - FFANHVS * (Ip Mod 2)

        sngRad(1) = FFANHRD - FFANHVS * ((Ip + 1) Mod 2)

        sngRad(2) = FFANLRD - FFANLVS * (Ip Mod 2)

        sngRad(3) = FFANLRD - FFANLVS * ((Ip + 1) Mod 2)

        For Jp = 0 To 3

            Kp = Choose(Jp + 1, 0, 1, 3, 2)

       sngPly(Kp, 0) = sngRad(Jp) * Cos(sngAng(Jp Mod 2)) + FFANCXP

       sngPly(Kp, 1) = sngRad(Jp) * Sin(sngAng(Jp Mod 2)) + FFANCYP

        Next Jp

        sngPly(4, 0) = sngPly(0, 0): sngPly(4, 1) = sngPly(0, 1):

        With ActiveDocument.Shapes.AddPolyline(sngPly)

            .Fill.Visible = msoTrue

            .Fill.ForeColor = lngCol(1 + ((Ip - 1) Mod 2))

            .Line.Visible = msoTrue

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

        End With

    Next Ip

    '*外側扇描画

    For Ip = 0 To 1

        Kp = IIf(Ip = 0, 0, FFANOCN - 2)

        sngAng(0) = sngRdn * ((Kp + 0) * sngPan - (90 + FFANOAN \ 2))

        sngAng(1) = sngRdn * ((Kp + 2) * sngPan - (90 + FFANOAN \ 2))

        sngRad(0) = FFANHRD: sngRad(1) = FFANLRD

        For Jp = 0 To 3

            Kp = Choose(Jp + 1, 0, 1, 3, 2)

   sngPly(Kp, 0) = sngRad(Jp \ 2) * Cos(sngAng(Jp Mod 2)) + FFANCXP

   sngPly(Kp, 1) = sngRad(Jp \ 2) * Sin(sngAng(Jp Mod 2)) + FFANCYP

        Next Jp

        sngPly(4, 0) = sngPly(0, 0): sngPly(4, 1) = sngPly(0, 1):

        With ActiveDocument.Shapes.AddPolyline(sngPly)

            .Fill.Visible = msoTrue

            .Fill.ForeColor = lngCol(1)             '←ぬりつぶし色

            .Line.Visible = msoTrue

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

        End With

    Next Ip

    '*端の骨を描画

    sngAng(0) = FFANOAN - 178 - (1 * 2) * sngPan

    sngAng(1) = sngRdn * sngAng(0)

    sngPly(0, 0) = (FFANLRD * FFANERV) * Cos(sngAng(1)) _

             - (FFANLRD * FFANERV) * Sin(sngAng(1)) + FFANCXP

    sngPly(0, 1) = (FFANLRD * FFANERV) * Sin(sngAng(1)) _

             + (FFANLRD * FFANERV) * Cos(sngAng(1)) + FFANCYP

    '

    With ActiveDocument.Shapes.AddShape( _

           msoShapeFlowchartTerminator, _

  sngPly(0, 0) - FFANBWD \ 2, sngPly(0, 1) - FFANLRD * FFANESZ / 2, _

                       FFANBWD, FFANLRD * FFANESZ)

        .Fill.Visible = msoTrue

        .Fill.ForeColor.RGB = lngCol(3)

        .Line.Visible = msoTrue

        .Line.ForeColor.RGB = lngCol(0)

        .Rotation = sngAng(0) - 45

    End With

End Sub