Quelltext:
unit FontUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
TrackBar1: TTrackBar;
TrackBar2: TTrackBar;
TrackBar3: TTrackBar;
FontDialog1: TFontDialog;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure TrackBar2Change(Sender: TObject);
procedure TrackBar3Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TVector = array of Extended;
TMatrix = record
cols: Integer;
rows: Integer;
data: array of TVector;
end;
TPoint3D = record
X, Y, Z: Extended;
end;
var
polytext: string = '3D Text';
polypoints: array of TPoint;
polypoints2D: array of TPoint;
polypoints3D: array of TPoint3D;
polytypes: array of Byte;
P0, Pox, Poy, Poz, Px, Py, Pz: TPoint3D;
function clearmatrix: TMatrix;
begin
result.cols:=0;
result.rows:=0;
result.data:=nil;
end;
function creatematrix(cols, rows: Integer): TMatrix;
var i, j: Integer;
begin
result.cols:=cols;
result.rows:=rows;
SetLength(result.data, cols);
for i:=0 to cols-1 do
begin
SetLength(result.data[i], rows);
for j:=0 to rows-1 do
result.data[i, j]:=0;
end;
end;
procedure destroymatrix(var mx: TMatrix);
var i: Integer;
begin
for i:=0 to mx.cols-1 do
Finalize(mx.data[i]);
Finalize(mx.data);
mx:=clearmatrix;
end;
procedure fillmatrix(var mx: TMatrix; value: Extended);
var i, j: Integer;
begin
for j:=0 to mx.rows-1 do
for i:=0 to mx.cols-1 do
mx.data[i, j]:=value;
end;
function multmatrix(mxA, mxB: TMatrix): TMatrix;
var ai, aj, bi, bj: Integer;
begin
result:=clearmatrix;
if (mxA.cols<>mxB.rows) then
Exit;
result:=creatematrix(mxB.cols, mxA.rows);
fillmatrix(result, 0);
for aj:=0 to mxA.rows-1 do
for bi:=0 to mxB.cols-1 do
for ai:=0 to mxA.cols-1 do //weil: mxA.cols=mxB.rows
begin
bj:=ai;
result.data[bi, aj]:=result.data[bi, aj]+mxA.data[ai, aj]*mxB.data[bi, bj];
end
end;
//
function XSin(angle: Extended): Extended;
begin
result:=Sin((angle*Pi)/180);
end;
function XCos(angle: Extended): Extended;
begin
result:=Cos((angle*Pi)/180);
end;
//
function Point3D(X, Y, Z: Extended): TPoint3D;
begin
result.X:=X;
result.Y:=Y;
result.Z:=Z;
end;
//
function Point3DToPoint2D(Point3D: TPoint3D): TPoint;
begin
result.x:=Round(Point3D.X);
result.y:=Round(Point3D.Y);
end;
//
function XRotateMatrix(angle: Extended): TMatrix;
begin
result:=creatematrix(4, 4);
with result do
begin
data[0, 0]:=1;
data[0, 1]:=0;
data[0, 2]:=0;
data[0, 3]:=0;
data[1, 0]:=0;
data[1, 1]:=XCos(angle);
data[1, 2]:=-XSin(angle);
data[1, 3]:=0;
data[2, 0]:=0;
data[2, 1]:=XSin(angle);
data[2, 2]:=XCos(angle);
data[2, 3]:=0;
data[3, 0]:=0;
data[3, 1]:=0;
data[3, 2]:=0;
data[3, 3]:=1;
end;
end;
function YRotateMatrix(angle: Extended): TMatrix;
begin
result:=creatematrix(4, 4);
with result do
begin
data[0, 0]:=XCos(angle);
data[0, 1]:=0;
data[0, 2]:=XSin(angle);
data[0, 3]:=0;
data[1, 0]:=0;
data[1, 1]:=1;
data[1, 2]:=0;
data[1, 3]:=0;
data[2, 0]:=-XSin(angle);
data[2, 1]:=0;
data[2, 2]:=XCos(angle);
data[2, 3]:=0;
data[3, 0]:=0;
data[3, 1]:=0;
data[3, 2]:=0;
data[3, 3]:=1;
end;
end;
function ZRotateMatrix(angle: Extended): TMatrix;
begin
result:=creatematrix(4, 4);
with result do
begin
data[0, 0]:=XCos(angle);
data[0, 1]:=-XSin(angle);
data[0, 2]:=0;
data[0, 3]:=0;
data[1, 0]:=XSin(angle);
data[1, 1]:=XCos(angle);
data[1, 2]:=0;
data[1, 3]:=0;
data[2, 0]:=0;
data[2, 1]:=0;
data[2, 2]:=1;
data[2, 3]:=0;
data[3, 0]:=0;
data[3, 1]:=0;
data[3, 2]:=0;
data[3, 3]:=1;
end;
end;
procedure Rotate(alpha, beta, gamma: Extended; flag: Boolean);
var i: Integer;
Rx, Ry, Rz, Rt, Rm, Xm, Xim, Ym, Yim, Zm, Zim: TMatrix;
procedure FillM(var M: TMatrix; P: TPoint3D);
begin
M.data[0, 0]:=P.X;
M.data[0, 1]:=P.Y;
M.data[0, 2]:=P.Z;
M.data[0, 3]:=0;
end;
function TurnP(P: TPoint3D): TPoint3D;
var M, Mi: TMatrix;
begin
M:=creatematrix(1, 4);
FillM(M, P);
Mi:=multmatrix(Rm, M);
result:=Point3D(Mi.data[0, 0], Mi.data[0, 1], Mi.data[0, 2]);
destroymatrix(M);
destroymatrix(Mi);
end;
begin
Rx:=XRotateMatrix(alpha);
Ry:=YRotateMatrix(beta);
Rz:=ZRotateMatrix(gamma);
Rt:=multmatrix(Rx, Ry);
Rm:=multmatrix(Rt, Rz);
if flag then
begin
Px:=Pox;
Py:=Poy;
Pz:=Poz;
Px:=TurnP(Px);
Py:=TurnP(Py);
Pz:=TurnP(Pz);
end
else
begin
SetLength(polypoints3D, Length(polypoints));
for i:=0 to High(polypoints) do
polypoints3D[i]:=TurnP(Point3D(polypoints[i].x, polypoints[i].y, 0));
end;
destroymatrix(Rx);
destroymatrix(Ry);
destroymatrix(Rz);
destroymatrix(Rt);
destroymatrix(Rm);
end;
//
procedure Line(Canvas: TCanvas; pt1, pt2: TPoint);
begin
Canvas.MoveTo(pt1.X, pt1.Y);
Canvas.LineTo(pt2.X, pt2.Y);
end;
//
procedure FontToPolygon(Font: TFont; s: string);
var i: Integer;
b: Byte;
pt: TPoint;
bmp: TBitmap;
begin
bmp:=TBitmap.Create;
BeginPath(bmp.Canvas.Handle);
bmp.Canvas.Font:=Font;
bmp.Canvas.Brush.Style:=bsClear;
bmp.Canvas.TextOut(0, 0, s);
EndPath(bmp.Canvas.Handle);
FlattenPath(bmp.Canvas.Handle); //Glätten
pt:=Point(0, 0); b:=0;
i:=GetPath(bmp.Canvas.Handle, @pt, @b, 0);
SetLength(polypoints, i);
SetLength(polytypes, i);
GetPath(bmp.Canvas.Handle, @polypoints[0], @polytypes[0], i);
AbortPath(bmp.Canvas.Handle);
bmp.Free;
end;
function PolygonToRgn: HRGN;
var i, j: Integer;
rgn: HRGN;
begin
i:=0; j:=0; result:=0;
while i<=High(polypoints2D) do
begin
if (polytypes[i] and PT_CLOSEFIGURE)<>0 then
begin
if result=0 then
result:=CreatePolygonRgn(polypoints2D[j], i-j+1, WINDING)
else
begin
rgn:=CreatePolygonRgn(polypoints2D[j], i-j+1, WINDING);
CombineRgn(result, result, rgn, RGN_XOR);
DeleteObject(rgn);
end;
j:=i+1;
end;
inc(i);
end;
end;
//
procedure TForm1.FormCreate(Sender: TObject);
begin
P0:=Point3D(0, 0, 0);
Pox:=Point3D(200, 0, 0);
Poy:=Point3D(0, 200 ,0);
Poz:=Point3D(0, 0, 200);
Px:=Point3D(200, 0, 0);
Py:=Point3D(0, 200, 0);
Pz:=Point3D(0, 0, 200);
FontToPolygon(Font, polytext);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Finalize(polypoints);
Finalize(polypoints2D);
Finalize(polypoints3D);
Finalize(polytypes);
end;
procedure TForm1.FormPaint(Sender: TObject);
var i: Integer;
pt0, ptx, pty, ptz: TPoint;
rgn: HRGN;
begin
Canvas.Brush.Color:=clBtnFace;
Canvas.FillRect(ClientRect);
//Achsen
SetMapMode(Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil); //darzustellende Punkte x,y
SetViewportExtEx(Canvas.Handle, ClientWidth, -ClientHeight, nil); //kippen an
SetViewportOrgEx(Canvas.Handle, ClientWidth div 2, ClientHeight div 2, nil); //Nullpunkt
//Punkte rotieren
Rotate(-TrackBar1.Position, TrackBar2.Position, TrackBar3.Position, True);
//Punkte umrechnen
pt0:=Point3DToPoint2D(P0);
ptx:=Point3DToPoint2D(Px);
pty:=Point3DToPoint2D(Py);
ptz:=Point3DToPoint2D(Pz);
//Zeichnen
Canvas.Pen.Color:=clBlack;
Line(Canvas, pt0, ptx); Canvas.TextOut(ptx.x, ptx.y, 'X');
Line(Canvas, pt0, pty); Canvas.TextOut(pty.x, pty.y, 'Y');
Line(Canvas, pt0, ptz); Canvas.TextOut(ptz.x, ptz.y, 'Z');
//Text ***********************************************************************
SetMapMode(Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil); //darzustellende Punkte x,y
SetViewportExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil); //kippen aus
SetViewportOrgEx(Canvas.Handle, 0, 0, nil); //Nullpunkt
//Punkte rotieren
Rotate(TrackBar1.Position, TrackBar2.Position, -TrackBar3.Position, False);
//Punkte umrechnen
SetLength(polypoints2D, Length(polypoints3D));
for i:=0 to High(polypoints2D) do
begin
polypoints2D[i]:=Point3DToPoint2D(polypoints3D[i]);
polypoints2D[i].X:=polypoints2D[i].X+ClientWidth div 2;
polypoints2D[i].Y:=polypoints2D[i].Y+ClientHeight div 2;
end;
//Zeichnen
rgn:=PolygonToRgn;
Canvas.Brush.Color:=clGreen;
FillRgn(Canvas.Handle, rgn, Canvas.Brush.Handle);
DeleteObject(rgn);
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Label1.Caption:='X: '+inttostr(TrackBar1.Position);
Invalidate;
end;
procedure TForm1.TrackBar2Change(Sender: TObject);
begin
Label2.Caption:='Y: '+inttostr(TrackBar2.Position);
Invalidate;
end;
procedure TForm1.TrackBar3Change(Sender: TObject);
begin
Label3.Caption:='Z: '+inttostr(TrackBar3.Position);
Invalidate;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FontDialog1.Font:=Font;
if FontDialog1.Execute then
begin
Font:=FontDialog1.Font;
FontToPolygon(Font, polytext);
Invalidate;
end;
end;
end.
object Form1: TForm1
Left = 225
Top = 104
Caption = 'Form1'
ClientHeight = 519
ClientWidth = 716
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -21
Font.Name = 'Teen Light'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
OnPaint = FormPaint
TextHeight = 24
object Label1: TLabel
Left = 528
Top = 8
Width = 34
Height = 24
AutoSize = False
Caption = 'X'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
end
object Label2: TLabel
Left = 528
Top = 32
Width = 34
Height = 24
AutoSize = False
Caption = 'Y'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
end
object Label3: TLabel
Left = 528
Top = 56
Width = 34
Height = 24
AutoSize = False
Caption = 'Z'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
end
object Button1: TButton
Left = 576
Top = 88
Width = 75
Height = 25
Caption = 'Font'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 0
OnClick = Button1Click
end
object TrackBar1: TTrackBar
Left = 568
Top = 8
Width = 150
Height = 24
Max = 360
TabOrder = 1
TickMarks = tmBoth
TickStyle = tsNone
OnChange = TrackBar1Change
end
object TrackBar2: TTrackBar
Left = 568
Top = 32
Width = 150
Height = 24
Max = 360
TabOrder = 2
TickMarks = tmBoth
TickStyle = tsNone
OnChange = TrackBar2Change
end
object TrackBar3: TTrackBar
Left = 568
Top = 56
Width = 150
Height = 24
Max = 360
TabOrder = 3
TickMarks = tmBoth
TickStyle = tsNone
OnChange = TrackBar3Change
end
object FontDialog1: TFontDialog
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Left = 576
Top = 120
end
end
|
