Skip to main content
Mathematica

Return to Answer

deleted 1 character in body
Source Link
ktm
ktm
  • 4.3k
  • 22
  • 30

Here is a method that finds the earliest x value and the mean y value used to createin creating the word graphicscharacters, and subtracts all content in the graphic by these values to normalize the first character to {0, 0}:

TextToOutlines[style_] := Module[{content, x, y, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {x, y} = 
   MinMax /@ 
    Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xadj, y - yadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

enter image description here

Here is a method that finds the earliest x value and the mean y value used to create the word graphics, and subtracts all content in the graphic by these values to normalize the first character to {0, 0}:

TextToOutlines[style_] := Module[{content, x, y, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {x, y} = 
   MinMax /@ 
    Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xadj, y - yadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

enter image description here

Here is a method that finds the earliest x value and the mean y value used in creating the characters, and subtracts all content in the graphic by these values to normalize the first character to {0, 0}:

TextToOutlines[style_] := Module[{content, x, y, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {x, y} = 
   MinMax /@ 
    Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xadj, y - yadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

enter image description here

deleted 461 characters in body
Source Link
ktm
ktm
  • 4.3k
  • 22
  • 30

(partial answer)

Here is a method that finds the lowestearliest x value and the mean y numerical pointvalue used to create the word graphics, and subtracts all content in the graphic by these values to normalize the first character to {0,0 0}:

TextToOutlines[style_] := Module[{content, xminx, yminy, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {xminx, yminy} = 
   MinMinMax /@ Transpose[
     Cases[content[[2Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xminxadj, y - yminyadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

Fubar

This falls apart pretty quickly if any of the letters you're using have "feet" though, i.e.

Show[Graphics@
    TextToOutlines@
     Style["Fybar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

fybar

If I have time later today maybe I'll try to think of a method that can overcome this. It might be a useful start for someone else trying to tackle the issue, though.enter image description here

(partial answer)

Here is a method that finds the lowest x and y numerical point used to create the word, and subtracts all content in the graphic by these values to normalize the first character to {0,0}:

TextToOutlines[style_] := Module[{content, xmin, ymin},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {xmin, ymin} = 
   Min /@ Transpose[
     Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xmin, y - ymin}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

Fubar

This falls apart pretty quickly if any of the letters you're using have "feet" though, i.e.

Show[Graphics@
    TextToOutlines@
     Style["Fybar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

fybar

If I have time later today maybe I'll try to think of a method that can overcome this. It might be a useful start for someone else trying to tackle the issue, though.

Here is a method that finds the earliest x value and the mean y value used to create the word graphics, and subtracts all content in the graphic by these values to normalize the first character to {0, 0}:

TextToOutlines[style_] := Module[{content, x, y, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {x, y} = 
   MinMax /@ 
    Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xadj, y - yadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

enter image description here

Source Link
ktm
ktm
  • 4.3k
  • 22
  • 30

(partial answer)

Here is a method that finds the lowest x and y numerical point used to create the word, and subtracts all content in the graphic by these values to normalize the first character to {0,0}:

TextToOutlines[style_] := Module[{content, xmin, ymin},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {xmin, ymin} = 
   Min /@ Transpose[
     Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xmin, y - ymin}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

Fubar

This falls apart pretty quickly if any of the letters you're using have "feet" though, i.e.

Show[Graphics@
    TextToOutlines@
     Style["Fybar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]

fybar

If I have time later today maybe I'll try to think of a method that can overcome this. It might be a useful start for someone else trying to tackle the issue, though.