本文整理自网络，侵删。
unit beziertext;
interface
uses Windows, Graphics, Math;
procedure TextAlongBezier(canvas: TCanvas; bezierPts: array of TPoint; const s: string);
implementation
//--------------------------------------------------------------------------//Helper functions//--------------------------------------------------------------------------
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;
//--------------------------------------------------------------------------// TextAlongBezier()//--------------------------------------------------------------------------
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;//--------------------------------------------------------------------------
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)], ' Try this quick quiz ');end;
相关阅读 >>
Delphi获取flash文件的影片时长,原始尺寸,帧数等信息
更多相关阅读请进入《Delphi》频道 >>
