Draw Bezier Fonts

uses Math

//

function DistanceBetween2Pts(pt1,pt2: TPoint): single;
begin
  result := sqrt((pt1.X - pt2.X)*(pt1.X - pt2.X) +
    (pt1.Y - pt2.Y)*(pt1.Y - pt2.Y));
end;

function GetPtAtDistAndAngleFromPt(pt: TPoint;
  dist: integer; angle: single): TPoint;
begin
  result.X := round(dist * cos(angle));
  result.Y := -round(dist * sin(angle)); //nb: Y axis is +ve down
  inc(result.X , pt.X);
  inc(result.Y , pt.Y);
end;

function PtBetween2Pts(pt1, pt2: TPoint;
  relativeDistFromPt1: single): TPoint;
begin
  //nb: 0 <= relativeDistFromPt1 <= 1
  if pt2.X = pt1.X then
    result.X := pt2.X else
    result.X := pt1.X + round((pt2.X - pt1.X)*relativeDistFromPt1);
  if pt2.Y = pt1.Y then
    result.Y := pt2.Y else
    result.Y := pt1.Y + round((pt2.Y - pt1.Y)*relativeDistFromPt1);
end;

function GetAnglePt2FromPt1(pt1, pt2: TPoint): single;
begin
  //nb: result is in radians
  dec(pt2.X,pt1.X);
  dec(pt2.Y,pt1.Y);
  with pt2 do
    if X = 0 then
    begin
      result := pi/2;
      if Y > 0 then result := 3*result; //nb: Y axis is +ve down
    end else
    begin
      result := arctan2(-Y,X);
      if result < 0 then result := result + pi * 2;
    end;
end;

procedure AngledCharOut(Canvas: TCanvas; pt: TPoint;
  c: char; radians: single; offsetX, offsetY: integer);
var
  lf: TLogFont;
  OldFontHdl,NewFontHdl: HFont;
  angle: integer;
begin
  angle := round(radians * 180/pi);
  if angle > 180 then angle := angle - 360;

  //workaround because textout() without any rotation is malaligned
  //relative to other rotated text ...
  if angle = 0 then angle := 1;

  with Canvas do
  begin
    //create an angled font based on the current canvas's font ...
    if GetObject(Font.Handle, SizeOf(lf), @lf) = 0 then exit;
    lf.lfEscapement := Angle * 10;
    lf.lfOrientation := Angle * 10;
    lf.lfOutPrecision := OUT_TT_ONLY_PRECIS;
    NewFontHdl := CreateFontIndirect(lf);
    OldFontHdl := selectObject(handle,NewFontHdl);
    //offset the character by the (rotated) X & Y amounts ...
    if offsetX < 0 then
      pt := GetPtAtDistAndAngleFromPt(pt, -offsetX, radians + Pi)
    else if offsetX > 0 then
      pt := GetPtAtDistAndAngleFromPt(pt, offsetX, radians);
    if offsetY < 0 then
      pt := GetPtAtDistAndAngleFromPt(pt, -offsetY, radians + pi/2)
    else if offsetY > 0 then
      pt := GetPtAtDistAndAngleFromPt(pt, offsetY, radians - pi/2);
    //draw the rotated character ...
    TextOut(pt.x, pt.y, c);
    //finally restore the unrotated canvas font ...
    selectObject(handle,OldFontHdl);
    DeleteObject(NewFontHdl);
  end;
end;

procedure TextAlongBezier(canvas: TCanvas;
  bezierPts: array of TPoint; const s: string);
var
  i, j, ptCnt, textLenPxls, textLenChars, vertOffset: integer;
  currentInsertionDist, charWidthDiv2: integer;
  pt: TPoint;
  flatPts: array of TPoint;
  types: array of byte;
  distances: array of single;
  dummyPtr: pointer;
  angle, spcPxls, bezierLen, relativeDistFRomPt1: single;
  charWidths: array[#32..#255] of integer;
begin
  textLenChars := length(s);
  //make sure there's text and a valid number of bezier points ...
  if (textLenChars = 0) or (high(bezierPts) mod 3 <> 0) then exit;

  with canvas do
  begin
    //Create the path ...
    BeginPath(handle);
    PolyBezier(bezierPts);
    EndPath(handle);
    //'Flatten' the path ...
    FlattenPath(handle);

    //Get Character widths for every printable character of the given font
    if not GetCharWidth32(handle,32,255, charWidths[#32]) then exit;

    //First get the number of points needed to define the 'flattened' path
    dummyPtr := nil; //nb: dummyPtr will be ignored in the GetPath() call
    ptCnt := GetPath(handle, dummyPtr, dummyPtr, 0);
    if ptCnt < 1 then exit;

    setLength(flatPts, ptCnt);
    setLength(types, ptCnt);
    setLength(distances, ptCnt);

    //Now we know the number of points needed, call GetPath() again
    //this time assigning the array of points (flatPts) ...
    GetPath(handle, flatPts[0], types[0], ptCnt);

    //calculate and fill the distances array ...
    distances[0] := 0;
    bezierLen := 0;
    for i := 1 to ptCnt -1 do
    begin
      bezierLen := bezierLen +
        DistanceBetween2Pts(flatPts[i], flatPts[i-1]);
      distances[i] := bezierLen;
    end;

    //calc length of text in pixels ...
    textLenPxls := 0;
    for i := 1 to textLenChars do inc(textLenPxls, charWidths[s[i]]);

    //calc space between chars to spread string along entire curve ...
    if textLenChars = 1 then
      spcPxls := 0 else
      spcPxls := (bezierLen - textLenPxls)/(textLenChars -1);

    SetBkMode (handle, TRANSPARENT);

    //Position the text over the top of the curve.
    //Empirically, moving characters up 2/3 of TextHeight seems OK ...
    vertOffset := -trunc(2/3* TextHeight('Yy'));

    j := 1;
    currentInsertionDist := 0;
    for i := 1 to textLenChars do
    begin
      charWidthDiv2 := charWidths[s[i]] div 2;
      //increment currentInsertionDist half the width of char to get
      //the slope of the curve at the midpoint of that character ...
      inc(currentInsertionDist, charWidthDiv2);

      //find the point on the flattened path corresponding to the
      //midpoint of the current character ...
      while (j < ptCnt -1) and (distances[j] < currentInsertionDist) do
        inc(j);
      if distances[j] = currentInsertionDist then
        pt := flatPts[j]
      else
      begin
        relativeDistFRomPt1 := (currentInsertionDist - distances[j-1]) /
          (distances[j] - distances[j-1]);
        pt := PtBetween2Pts(flatPts[j-1],flatPts[j],relativeDistFRomPt1);
      end;
      //get the angle of the path at this point ...
      angle := GetAnglePt2FromPt1(flatPts[j-1], flatPts[j]);

      //finally, draw the character at the given angle  ...
      AngledCharOut(canvas,pt,s[i], angle, -charWidthDiv2, vertOffset);

      //increment currentInsertionDist to the start of next character ...
      inc(currentInsertionDist,
        charWidthDiv2 + trunc(spcPxls) + round(frac(spcPxls*i)));
    end;

    //debug only - draw the path from the points ...
    //with flatPts[0] do canvas.moveto(X,Y);
    //for i := 1 to ptCnt -1 do with flatPts[i] do canvas.lineto(X,Y);
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
 Font.Name := 'Tahoma';
 Font.Size := 48;
 Font.Style := [fsBold];
 TextAlongBezier(
      canvas,
      [Point(300,100),
      Point(500,100),
      Point(500,400),
      Point(300,400),
      Point(100,400),
      Point(100,100),
      Point(300,100)],
      ' Hello world - hackbard ');

end;