Update: added a version using Inset below the original answer
Options[drawArrow] = {ArrowFillColor -> Black,
ArrowEdgeThickness -> 0.02, ArrowEdgeColor -> Black,
ArrowFillOpacity -> 1, ArrowEdgeOpacity -> 1,
LeftArrowSpacing -> 0, RightArrowSpacing -> 0};
drawArrow[{shaftEndLeft_, shaftMidLeft_, shaftEndMid_, baseMidLeft_,
innerMidLeft_, innerBaseLeft_, outerBaseLeft_, outerMidLeft_,
top_}, pstart_, pend_, OptionsPattern[]] :=
Module[{baseMidRight, outerMidRight, innerMidRight, innerBaseRight,
outerBaseRight, shaftEndRight, shaftMidRight},
shaftEndRight = {1, -1} shaftEndLeft;
shaftMidRight = {1, -1} shaftMidLeft;
baseMidRight = {1, -1} baseMidLeft;
innerBaseRight = {1, -1} innerBaseLeft;
outerBaseRight = {1, -1} outerBaseLeft;
outerMidRight = {1, -1} outerMidLeft;
innerMidRight = {1, -1} innerMidLeft;
{
If[OptionValue[ArrowEdgeColor] === None, EdgeForm[],
EdgeForm[
Directive[Thickness[OptionValue[ArrowEdgeThickness]],
OptionValue[ArrowEdgeColor],
Opacity[OptionValue[ArrowEdgeOpacity]]]]],
If[OptionValue[ArrowFillColor] === None, FaceForm[],
FaceForm[
Directive[Opacity[OptionValue[ArrowFillOpacity]],
OptionValue[ArrowFillColor]]]],
GeometricTransformation[
FilledCurve[
{
Line[{shaftEndMid, shaftEndLeft}],
BSplineCurve[{shaftEndLeft, shaftMidLeft, baseMidLeft}],
BSplineCurve[{baseMidLeft, innerMidLeft, innerBaseLeft}],
Line[{innerBaseLeft, outerBaseLeft}],
BSplineCurve[{outerBaseLeft, outerMidLeft, top}],
BSplineCurve[{top, outerMidRight, outerBaseRight}],
Line[{outerBaseRight, innerBaseRight}],
BSplineCurve[{innerBaseRight, innerMidRight, baseMidRight}],
BSplineCurve[{baseMidRight, shaftMidRight, shaftEndRight}],
Line[{shaftEndRight, shaftEndMid}]
}
], FindGeometricTransform[{pstart,
pend}, {shaftEndMid + {-OptionValue[
LeftArrowSpacing] EuclideanDistance[shaftEndMid, top], 0},
top + {OptionValue[RightArrowSpacing] EuclideanDistance[
shaftEndMid, top], 0}}][[2]]
]
}
]
DynamicModule[{top, fill, edge, arrowFillColor, arrowEdgeColor,
arrowFillOpacity, arrowEdgeThickness, arrowEdgeOpacity},
Manipulate[
top = {0, 0};
shaftEndMid = {1, 0} shaftEndMid;
Graphics[
h = drawArrow2[{shaftEndLeft, shaftMidLeft, shaftEndMid,
baseMidLeft, innerMidLeft, innerBaseLeft, outerBaseLeft,
outerMidLeft, top}, shaftEndMid, top,
ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity
];
h /. {drawArrow2 -> drawArrow},
PlotRange -> {{-7, 2}, {-2, 2}},
GridLines -> {Range[-7, 2, 1/4], Range[-2, 2, 1/4]},
GridLinesStyle -> Dotted,
ImageSize -> 800,
AspectRatio -> Automatic
],
{{shaftEndLeft, {-6.5, 1}}, Locator},
{{shaftMidLeft, {-4, 1/2}}, Locator},
{{shaftEndMid, {-6, 0}}, Locator},
{{baseMidLeft, {-2, 0.2}}, Locator},
{{innerMidLeft, {-2, 0.5}}, Locator},
{{innerBaseLeft, {-2, 1}}, Locator},
{{outerBaseLeft, {-2, 1.1}}, Locator},
{{outerMidLeft, {-1, 1}}, Locator},
Grid[
{
{Style["Fill", Bold, 16],
Control@{{fill, True, "Fill"}, {True, False}}, " ",
Control@{{arrowFillColor, Yellow, "Color"}, Yellow}, " ",
Control@{{arrowFillOpacity, 0.5, "Opacity"}, 0, 1}, "", ""},
{Style["Edge", Bold, 16],
Control@{{edge, True, "Edge"}, {True, False}}, " ",
Control@{{arrowEdgeColor, Orange, "Color"}, Orange}, " ",
Control@{{arrowEdgeThickness, 0.02, "Thickness"}, 0, 0.1}, " ",
Control@{{arrowEdgeOpacity, 1, "Opacity"}, 0, 1}}
}\[Transpose]
, Alignment -> Left,
Dividers -> {{True, True, {False}, True}, {True, True, {False},
True}}
],
Button["Copy to clipboard",
CopyToClipboard[
h /. {drawArrow2 -> Defer[drawArrow]}
],
ImageSize -> Automatic
]
]
]
UPDATE
I was not satisfied with the behavior of the line thickness in the arrow definition. The problem was discussed in this question. I implemented the Inset idea of Mr.Wizard and also improved the clipboard copying, based on Simon's idea, but got rid of his Sequence that ended up as junk in the copied code. At the bottom the new code. A result is shown here:
Show[
Graph[GraphData["DodecahedralGraph", "EdgeRules"],
VertexShape -> Graphics@{Red, Disk[]},
EdgeShapeFunction ->
Function[{p$, v$},
drawArrow @@ {{{-6.2059999999999995`,
0.3650000000000002`}, {-4.052`, 1.045`}, {-6.156`,
0.`}, {-1.5380000000000003`,
0.2549999999999999`}, {-0.9879999999999995`,
0.46499999999999986`}, {-2, 1}, {-1.428`, 1.435`}, {-1,
1}, {0, 0}}, p$[[1]],
p$[[2]], {ArrowFillColor ->
RGBColor[0.`, 0.61538109407187`, 0.1625391012436103`],
ArrowFillOpacity -> 0.462`, ArrowEdgeThickness -> 0.0616`,
ArrowEdgeColor ->
RGBColor[0.06968795300221256`, 0.30768291752498667`, 0.`],
ArrowEdgeOpacity -> 1}}],
VertexCoordinates ->
MapIndexed[First[#2] -> #1 &,
GraphData["DodecahedralGraph", "VertexCoordinates"]]],
Method -> {"ShrinkWrap" -> True}
]
(Note the "ShrinkWrap". Using Inset apparently generates a lot of white space that has to be cropped)
The code:
Options[drawArrow] = {ArrowFillColor -> Black,
ArrowEdgeThickness -> 0.02, ArrowEdgeColor -> Black,
ArrowFillOpacity -> 1, ArrowEdgeOpacity -> 1,
LeftArrowSpacing -> 0, RightArrowSpacing -> 0};
drawArrow[{shaftEndLeft_, shaftMidLeft_, shaftEndMid_, baseMidLeft_,
innerMidLeft_, innerBaseLeft_, outerBaseLeft_, outerMidLeft_,
top_}, pstart_, pend_, OptionsPattern[]] :=
Module[{baseMidRight, outerMidRight, innerMidRight, innerBaseRight,
outerBaseRight, shaftEndRight, shaftMidRight},
shaftEndRight = {1, -1} shaftEndLeft;
shaftMidRight = {1, -1} shaftMidLeft;
baseMidRight = {1, -1} baseMidLeft;
innerBaseRight = {1, -1} innerBaseLeft;
outerBaseRight = {1, -1} outerBaseLeft;
outerMidRight = {1, -1} outerMidLeft;
innerMidRight = {1, -1} innerMidLeft;
Inset[
Graphics[
{
If[OptionValue[ArrowEdgeColor] === None, EdgeForm[],
EdgeForm[
Directive[Thickness[OptionValue[ArrowEdgeThickness]],
OptionValue[ArrowEdgeColor],
Opacity[OptionValue[ArrowEdgeOpacity]]]]],
If[OptionValue[ArrowFillColor] === None, FaceForm[],
FaceForm[
Directive[Opacity[OptionValue[ArrowFillOpacity]],
OptionValue[ArrowFillColor]]]],
FilledCurve[
{
Line[{shaftEndMid, shaftEndLeft}],
BSplineCurve[{shaftEndLeft, shaftMidLeft, baseMidLeft}],
BSplineCurve[{baseMidLeft, innerMidLeft, innerBaseLeft}],
Line[{innerBaseLeft, outerBaseLeft}],
BSplineCurve[{outerBaseLeft, outerMidLeft, top}],
BSplineCurve[{top, outerMidRight, outerBaseRight}],
Line[{outerBaseRight, innerBaseRight}],
BSplineCurve[{innerBaseRight, innerMidRight, baseMidRight}],
BSplineCurve[{baseMidRight, shaftMidRight, shaftEndRight}],
Line[{shaftEndRight, shaftEndMid}]
}
]
},
PlotRangePadding -> 0,
PlotRange -> {{-7, 1}, {-2, 2}}
],
pstart, {-7, 0}, EuclideanDistance[pstart, pend], pend - pstart
]
]
DynamicModule[{top, fill, edge, arrowFillColor, arrowEdgeColor,
arrowFillOpacity, arrowEdgeThickness, arrowEdgeOpacity},
Manipulate[
top = {0, 0};
shaftEndMid = {1, 0} shaftEndMid;
Graphics[
drawArrow[{shaftEndLeft, shaftMidLeft, shaftEndMid, baseMidLeft,
innerMidLeft, innerBaseLeft, outerBaseLeft, outerMidLeft,
top}, {-7, 0}, {1, 0},
ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity
],
PlotRange -> {{-7, 1}, {-2, 2}},
GridLines -> {Range[-7, 1, 1/4], Range[-2, 2, 1/4]},
GridLinesStyle -> Dotted,
ImageSize -> 800,
AspectRatio -> Automatic
],
{{shaftEndLeft, {-6.5, 1}}, Locator},
{{shaftMidLeft, {-4, 1/2}}, Locator},
{{shaftEndMid, {-6, 0}}, Locator},
{{baseMidLeft, {-2, 0.2}}, Locator},
{{innerMidLeft, {-2, 0.5}}, Locator},
{{innerBaseLeft, {-2, 1}}, Locator},
{{outerBaseLeft, {-2, 1.1}}, Locator},
{{outerMidLeft, {-1, 1}}, Locator},
Grid[
{
{Style["Fill", Bold, 16],
Control@{{fill, True, "Fill"}, {True, False}}, " ",
Control@{{arrowFillColor, Yellow, "Color"}, Yellow}, " ",
Control@{{arrowFillOpacity, 0.5, "Opacity"}, 0, 1}, "", ""},
{Style["Edge", Bold, 16],
Control@{{edge, True, "Edge"}, {True, False}}, " ",
Control@{{arrowEdgeColor, Orange, "Color"}, Orange}, " ",
Control@{{arrowEdgeThickness, 0.02, "Thickness"}, 0, 0.1}, " ",
Control@{{arrowEdgeOpacity, 1, "Opacity"}, 0, 1}}
}\[Transpose]
, Alignment -> Left,
Dividers -> {{True, True, {False}, True}, {True, True, {False},
True}}
],
Button["Copy to clipboard",
With[
{
params = {shaftEndLeft, shaftMidLeft, shaftEndMid, baseMidLeft,
innerMidLeft, innerBaseLeft, outerBaseLeft, outerMidLeft, top},
opts = {ArrowFillColor -> If[fill, arrowFillColor, None],
ArrowFillOpacity -> arrowFillOpacity,
ArrowEdgeThickness -> arrowEdgeThickness,
ArrowEdgeColor -> If[edge, arrowEdgeColor, None],
ArrowEdgeOpacity -> arrowEdgeOpacity}
},
CopyToClipboard[
Defer[EdgeShapeFunction ->
Function[{p,
v}, (drawArrow @@ {params, p[[1]], p[[2]], opts})]]]
],
ImageSize -> Automatic
]
], SaveDefinitions -> True
]
