// Hiermit kann man
Strings endtlang einer Bézierkurve ausgeben. Die Grundidee
uses Types, Math;
var
Tabelle: array [#32 .. chr(65276)] of Integer;
ok: Boolean = false;
Canv: TCanvas;
procedure TForm1.FormCreate(Sender: TObject);
begin
Canv := Form1.Canvas; // <<< Hier die entsprechende Zeichenfläche festlegen
ok := GetCharWidth32W(Canv.Handle, 32, 65276, Tabelle[#32]);
end;
function Dist2(a, b: TPoint): single;
var
dx, dy: single;
begin
dx := sqr(a.X - b.X);
dy := sqr(a.Y - b.Y);
result := sqrt(dx + dy);
end;
function GetPtdst(pt: TPoint; dist: Integer; angle: single): TPoint;
begin
result.X := round(dist * cos(angle));
result.Y := -round(dist * sin(angle));
inc(result.X, pt.X);
inc(result.Y, pt.Y);
end;
function PDist2(a, b: TPoint; relativea: single): TPoint;
begin
if b.X = a.X then
result.X := b.X
else
result.X := a.X + round((b.X - a.X) * relativea);
if b.Y = a.Y then
result.Y := b.Y
else
result.Y := a.Y + round((b.Y - a.Y) * relativea);
end;
function Angleab(a, b: TPoint): single;
begin
dec(b.X, a.X);
dec(b.Y, a.Y);
with b do
if X = 0 then
begin
result := pi / 2;
if Y > 0 then
result := 3 * result;
end
else
begin
result := arctan2(-Y, X);
if result < 0 then
result := result + pi * 2;
end;
end;
function AnglechO(cn: TCanvas; pt: TPoint; c: char; bogenmss: single;
offsX, offsY: Integer): Boolean;
var
lf: TLogFont;
OldFontHdl, NewFontHdl: HFont;
angle: Integer;
p2: single;
begin
angle := round(bogenmss * 180 / pi);
if angle > 180 then
angle := angle - 360;
inc(angle, ord(angle = 0));
p2 := pi / 2;
with cn do
begin
if GetObject(Font.Handle, SizeOf(lf), @lf) = 0 then
begin
result := false;
exit;
end;
lf.lfEscapement := angle * 10;
lf.lfOrientation := angle * 10;
lf.lfOutPrecision := OUT_TT_ONLY_PRECIS;
NewFontHdl := CreateFontIndirect(lf);
OldFontHdl := selectObject(Handle, NewFontHdl);
if offsX < 0 then
pt := GetPtdst(pt, -offsX, bogenmss + pi)
else if offsX > 0 then
pt := GetPtdst(pt, offsX, bogenmss);
if offsY < 0 then
pt := GetPtdst(pt, -offsY, bogenmss + p2)
else if offsY > 0 then
pt := GetPtdst(pt, offsY, bogenmss - p2);
TextOut(pt.X, pt.Y, c);
selectObject(Handle, OldFontHdl);
DeleteObject(NewFontHdl);
result := true;
end;
end;
procedure TextKurve(cn: TCanvas; Pts: array of TPoint; const s: string);
var
i, j, ptCnt, txtLpx, txtLch, vertOffset: Integer;
CcInsDst, chWd2: Integer;
pt: TPoint;
flatPts: array of TPoint;
tps: array of byte;
distances: array of single;
dummyPtr: pointer;
angle, spcPxls, bezierLen, relDstP1: single;
begin
if not ok then
raise exception.Create('Die Belegung der Tabelle ist fehlgeschlagen.');
if Trim(s) = '' then
raise exception.Create('Es wurde kein Text gefunden.');
if high(Pts) mod 3 <> 0 then
raise exception.Create('Die Anzahl der Punkte ist unzulässig.');
txtLch := length(s);
with cn do
begin
BeginPath(Handle);
PolyBezier(Pts);
EndPath(Handle);
FlattenPath(Handle);
dummyPtr := nil;
ptCnt := GetPath(Handle, dummyPtr, dummyPtr, 0);
if ptCnt < 1 then
raise exception.Create('Der Schriftpfad wurde nicht ermittelt.');
setLength(flatPts, ptCnt);
setLength(tps, ptCnt);
setLength(distances, ptCnt);
GetPath(Handle, @flatPts[0], @tps[0], ptCnt);
distances[0] := 0;
bezierLen := 0;
for i := 1 to ptCnt - 1 do
begin
bezierLen := bezierLen + Dist2(flatPts[i], flatPts[i - 1]);
distances[i] := bezierLen;
end;
txtLpx := 0;
for i := 1 to txtLch do
inc(txtLpx, Tabelle[s[i]]);
if txtLch = 1 then
spcPxls := 0
else
spcPxls := (bezierLen - txtLpx) / (txtLch - 1);
SetBkMode(Handle, TRANSPARENT);
vertOffset := -trunc(2 / 3 * TextHeight('Äy'));
j := 1;
CcInsDst := 0;
for i := 1 to txtLch do
begin
chWd2 := Tabelle[s[i]] div 2;
inc(CcInsDst, chWd2);
while (j < ptCnt - 1) and (distances[j] < CcInsDst) do
inc(j);
if distances[j] = CcInsDst then
pt := flatPts[j]
else
begin
relDstP1 := (CcInsDst - distances[j - 1]) /
(distances[j] - distances[j - 1]);
pt := PDist2(flatPts[j - 1], flatPts[j], relDstP1);
end;
angle := Angleab(flatPts[j - 1], flatPts[j]);
if not AnglechO(cn, pt, s[i], angle, -chWd2, vertOffset) then
raise exception.Create('Die benötigte Schrift wurde nicht erstellt.');
inc(CcInsDst, chWd2 + trunc(spcPxls) + round(frac(spcPxls * i)));
end;
end;
end;
// Beispiel Bézierkurve (Bild 1)
procedure TForm1.Button1Click(Sender: TObject);
var
pt: array [0 .. 6] of TPoint;
begin
Canv.Font.Color := clRed;
Canv.Font.Name := 'Arial';
Canv.Font.Size := 16;
pt[0] := Point(125, 200);
pt[1] := Point(150, 250);
pt[2] := Point(225, 250);
pt[3] := Point(225, 175);
pt[4] := Point(275, 100);
pt[5] := Point(350, 100);
pt[6] := Point(350, 200);
TextKurve(Canv, pt, 'Das ist ein Versuch');
// nur zur Kontrolle:
Canv.Pen.Style := psDot;
Canv.PolyBezier(pt);
end;
// Beispiel Kreis (Bild 2)
procedure Kreis(cn: TCanvas; X, Y, Abstand, fSize: Integer; fName, txt: String;
cl: TColor);
var
pt: Array [0 .. 6] of TPoint;
a2, a15: Integer;
begin
cn.Font.Size := fSize;
cn.Font.Name := fName;
cn.Font.Color := cl;
a2 := Abstand * 2;
a15 := round(Abstand * 1.5);
pt[0] := Point(X + Abstand, Y);
pt[1] := Point(X + a2, Y);
pt[2] := Point(X + a2, Y + a15);
pt[3] := Point(X + Abstand, Y + a15);
pt[4] := Point(X, Y + a15);
pt[5] := Point(X, Y);
pt[6] := pt[0];
TextKurve(cn, pt, txt);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Kreis(Canv, 120, 100, 150, 14, 'Arial',
'Das ist einer von mehreren Versuchen. ', clBlack);
end;
// 2 Beispiele für Halbkreise
Procedure HalbKreisOben(cn: TCanvas; X, Y: Integer; const txt: String);
var
pt: array [0 .. 3] of TPoint;
M, M2: Integer;
begin
M := 145;
M2 := round(M * 1.5);
pt[0] := Point(X, Y + M);
pt[1] := Point(X, Y);
pt[2] := Point(X + M2, Y);
pt[3] := Point(X + M2, Y + M);
TextKurve(cn, pt, txt);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Canv.Font.Color := clRed;
Canv.Font.Size := 14;
Canv.Font.Name := 'Arial';
HalbKreisOben(Canv, 160, 65, 'Das ist ein Test');
end;
Procedure HalbKreisLinks(cn: TCanvas; X, Y: Integer; const txt: String);
var
pt: array [0 .. 3] of TPoint;
M, M2: Integer;
begin
M := 145;
M2 := round(M * 1.5);
pt[0] := Point(X + M, Y + M2);
pt[1] := Point(X, Y + M2);
pt[2] := Point(X, Y);
pt[3] := Point(X + M, Y);
TextKurve(cn, pt, txt);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Canv.Font.Color := clGreen;
Canv.Font.Name := 'Arial';
Canv.Font.Size := 14;
HalbKreisLinks(Canv, 120, 100, 'Das ist ein Versuch');
end;
|
