delphi Drawing Text 绘制文本

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;

//--------------------------------------------------------------------------

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;

//--------------------------------------------------------------------------

// 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.

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;

推荐分享