Graphics
From: 'Derek A. Benner' <dbenner@pacbell.net>
OK, Straight from 'Graphics File Formats, 2nd Edition' by David C. Kay & John R. Levine, here is the header format for the Targa image file.
Offset Length (in bytes) Description
------ ----------------- -----------
0 1 ID Field Length
1 1 Color-map Type
2 1 Image Type
(Color-map-specific Info)
3 2 First Color-map Entry
5 2 Color-map Length
7 1 Color-map Entry Size
(Image-specific Info)
8 2 Image X Origin
10 2 Image Y Origin
12 2 Image Width
14 2 Image Height
16 1 Bits-Per-Pixel
17 1 Image-Descriptor Bits
For True-color images the value of Color-map Type should be 0, while color-mapped images should set this to 1. If a color map is present, then Color-map Entry Size should be set to 15, 16, 24 or 32. For 15 and 16 values each color map entry is stored in two bytes in the format of:
High byte Low byte A RRRRR GG GGG BBBBB
with the 'A' bit set to 0 for 15-bit color values. 24-bit-sized entries are stored as three bytes in the order of (B)lue, (G)reen, and (R)ed. 32-bit-sized color map entries are stored in four bytes ordered as (B)lue, (G)reen, (R)ed and (A)ttribute values.
Further, the Image Type code should contain one of the following values:
Code Description ---- ----------- 0 No Image Present 1 Color-mapped, uncompressed 2 True-color, uncompressed 3 Black-&-White, uncompressed 9 Color-mapped, RLE compressed 10 True-color, RLE compressed 11 Black-&-White, RLE compressed
The Image X & Y Origins and the Image Width & Height fields are self-explanatory. Bits-Per-Pixel holds the number of bits per image pixel and should hold the values 8, 16, 24, or 32.
The Image Descriptor byte contains several bit fields that need to be extracted:
Bits Description ---- ----------- 0-3 Attribute Bits (Explained later) 4 Left-to-Right orientation 0=L/R 1=R/L 5 Top/Bottom orientation 0=B/T 1=T/B 6-7 Scan-Line Interleaving 00H=None, 40H=2way, 80H=4way
The Attribute bits are used to define the attributes of the colors in color-mapped or true-color pixels. 0 means no alpha data, 1 means undefined and ignorable, 2 means undefined but should be preserved, 3 means regular alpha data and 4 means the pixel information has already been multiplied by the alpha value.
Version 2.0 Targa files also have a file footer that may contain additional image and comment information. A version 2.0 Targa file always ends with the null-terminated string 'TRUEVISION-TARGA.'. So, if your Targa image ends with the values 'TRUEVISION-TARGA.' + 00H then you can extract the eight bytes prior to the string to find the start of the extension area and the developer directory positions within the file. Basically the Version 2.0 footer takes the format:
Byte Length Description ----- ------ ----------- 0 4 32-bit offset to Extension Area 4 4 32-bit offset to Developer Directory 8 17 TRUEVISION-TARGA. 25 1 Binary zero ($0)
I'm not going to give complete descriptions to the Developer's Directory or the Extension Area. Instead, I'm going to point out the postage-stamp info that the V2.0 Targa file *MAY* contain. This postage stamp is a miniature of the image, no larger than 64 X 64 pixels in size, *IF PRESENT*!
Extension Area
Offset Length Description ------ ------ ----------- 0 2 Extension Area Size (should be 495) 2 41 Author's Name 43 81 Author's Comments 124 81 Author's Comments 205 81 Author's Comments 286 81 Author's Comments 367 2 Creation Month 369 2 Creation Day 371 2 Creation Year .... ... ... 482 4 Color-correction table file offset 486 4 Postage-Stamp Image File Offset ****** 490 4 Scan-line table file offset 494 1 Attribute byte
This postage-stamp image, if present, may be directly usable by you. It is an uncompressed image in the same color format (Color-mapped or True-color) as the full image.
From: dmitrys@phyast.la.asu.edu (Dmitry Streblechenko)
In article <4uijv6$kf7@newsbf02.news.aol.com, gtabsoft2@aol.com (GTABSoft2) wrote: Does anyone have source code or info on drawing Bezier curves? I must have it for my component. Please respond to my email address.
I did this some time ago; I was too lazy to learn how to draw Bezier curves using Win API, so I did it using Polyline().
Note I used floating type values for points coordinates, (I used some kind of virtual screen), just change them to integer.
PBezierPoint = ^TBezierPoint;
TBezierPoint = record
X,Y:double; //main node
Xl,Yl:double; //left control point
Xr,Yr:double; //right control point
end;
//P1 and P2 are two TBezierPoint's, t is between 0 and 1:
//when t=0 X=P1.X, Y=P1.Y; when t=1 X=P2.X, Y=P2.Y;
procedure BezierValue(P1,P2:TBezierPoint; t:double; var X,Y:double);
var t_sq,t_cb,r1,r2,r3,r4:double;
begin
t_sq := t * t;
t_cb := t * t_sq;
r1 := (1 - 3*t + 3*t_sq - t_cb)*P1.X;
r2 := ( 3*t - 6*t_sq + 3*t_cb)*P1.Xr;
r3 := ( 3*t_sq - 3*t_cb)*P2.Xl;
r4 := ( t_cb)*P2.X;
X := r1 + r2 + r3 + r4;
r1 := (1 - 3*t + 3*t_sq - t_cb)*P1.Y;
r2 := ( 3*t - 6*t_sq + 3*t_cb)*P1.Yr;
r3 := ( 3*t_sq - 3*t_cb)*P2.Yl;
r4 := ( t_cb)*P2.Y;
Y := r1 + r2 + r3 + r4;
end;
To draw Bezier curve, split interval between P1 and P2 into several intervals based on how coarse you want your Bezier curve look (3 - 4 pixels looks Ok), then in a loop create an array of points using procedure above with t from 0 to 1 and draw that array of points using polyline().
From: saconn@iol.ie (Stephen Connolly)
gtabsoft2@aol.com (GTABSoft2) wrote: Does anyone have source code or info on drawing Bezier curves? I must have it for my component. Please respond to my email address.
I'm posting this here - 'cause: 1. I've seen people ask for this before, 2. The reference is so old I just had to. (BTW I have older references than this ;-P)
I'm sure that there is a standard Borland disclaimer to go with this:
(********************************************************************)
(* GRAPHIX TOOLBOX 4.0 *)
(* Copyright (c) 1985, 87 by Borland International, Inc. *)
(********************************************************************)
unit GShell;
interface
{-------------------------------- snip ----------------------------}
procedure Bezier(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer);
implementation
{-------------------------------- snip ---------------------------}
procedure Bezier{(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer)};
const
MaxControlPoints = 25;
type
CombiArray = array[0..MaxControlPoints] of Float;
var
N : integer;
ContrPoint, IntPoint : integer;
T, SumX, SumY, Prod, DeltaT, Quot : Float;
Combi : CombiArray;
begin
MaxContrPoints := MaxContrPoints - 1;
DeltaT := 1.0 / (MaxIntPoints - 1);
Combi[0] := 1;
Combi[MaxContrPoints] := 1;
for N := 0 to MaxContrPoints - 2 do
Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1);
for IntPoint := 1 to MaxIntPoints do
begin
T := (IntPoint - 1) * DeltaT;
if T <= 0.5 then
begin
Prod := 1.0 - T;
Quot := Prod;
for N := 1 to MaxContrPoints - 1 do
Prod := Prod * Quot;
Quot := T / Quot;
SumX := A[MaxContrPoints + 1, 1];
SumY := A[MaxContrPoints + 1, 2];
for N := MaxContrPoints downto 1 do
begin
SumX := Combi[N - 1] * A[N, 1] + Quot * SumX;
SumY := Combi[N - 1] * A[N, 2] + Quot * SumY;
end;
end
else
begin
Prod := T;
Quot := Prod;
for N := 1 to MaxContrPoints - 1 do
Prod := Prod * Quot;
Quot := (1 - T) / Quot;
SumX := A[1, 1];
SumY := A[1, 2];
for N := 1 to MaxContrPoints do
begin
SumX := Combi[N] * A[N + 1, 1] + Quot * SumX;
SumY := Combi[N] * A[N + 1, 2] + Quot * SumY;
end;
end;
B[IntPoint, 1] := SumX * Prod;
B[IntPoint, 2] := SumY * Prod;
end;
end; { Bezier }
end. { GShell }
David Ullrich <ullrich@math.okstate.edu>
Here's an FFT that handles 256 data points in about 0.008 seconds on a P66 (with 72MB, YMMV). Nothing but Delphi.
This one came out a lot nicer than the one I did a year ago. It's probably not optimal; if we want an optimal FFT we have to buy hardware, what the heck.
But I don't think it's too bad, performance-wise.
There's a little bit of recursion involved, but the recursion doesn't involve copying any data, just a few pointers;
if we have an array of length N = 2^d then the depth of the recursion is just d.
Possibly it could be improved by unwrapping the recursion, it's not clear whether it would be worth the trouble.
(But probably a person could get substantial inprovement with relatively little effort by unwrapping the bottom layer or two of the recursion, ie by saying
if Depth < 2 then
{do what needs to be done}
instead of the current 'if Depth = 0 then...'
This would eliminate function calls that do nothing but make assignments, a good thing, while OTOH unwrapping all of the resursion
would be trickier, and wouldn't seem as productive, since most of the function calls that would be eliminated do much more than just an assignment.)
There's a lookup table used for the sines and cosines; it could be that this is the wrong way to do it for large arrays, seems to work just fine for small to medium arrays.
Probably on a mchine with a lot of RAM a person would use VirtualAlloc(... PAGE_NOCACHE) for Src, Dest, and the lookup tables.
If anybody notices anything stupid about the way something's done not mentioned above please mention it.
What does it do, exactly? There are FFT's and FFT's - this one does the 'complex FT', that being the one I understand and care about. By this I mean that if N = 2^d and Src^ and Dest^ are arrays of N TComplexes, then a call
FFT(d, Src, Dest)
will fill in Dest with the complex FT: after the call Dest^[j] will equal
1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])
, where EiT(t) = cos(t) + i sin(t) . Ie, the standard Fourier Transform.
Comes in two versions: In the first version I use a TComplex, with functions to manipulate the complex numbers. In the second version everything's real - instead of arrays Src and Dest of complexes we have arrays SrcR, SrcI, DestR, DestI of reals (for the real and imagionary parts), and all those function calls are written out inline. The first one is much easier for me to make sense of, the second version is much faster. (They both give the 'complex FFT'.) With little programs that test whether it does what it should by checking Plancherel (aka Parseval). It really does work, btw - if it doesn't work for you it's because I garbled something in the process of deleting stupid comments. The complex version:
***
unit cplx;
interface
type
PReal = ^TReal;
TReal = extended;
PComplex = ^TComplex;
TComplex = record
r : TReal;
i : TReal;
end;
function MakeComplex(x, y: TReal): TComplex;
function Sum(x, y: TComplex) : TComplex;
function Difference(x, y: TComplex) : TComplex;
function Product(x, y: TComplex): TComplex;
function TimesReal(x: TComplex; y: TReal): TComplex;
function PlusReal(x: TComplex; y: TReal): TComplex;
function EiT(t: TReal):TComplex;
function ComplexToStr(x: TComplex): string;
function AbsSquared(x: TComplex): TReal;
implementation
uses SysUtils;
function MakeComplex(x, y: TReal): TComplex;
begin
with result do
begin
r:=x;
i:= y;
end;
end;
function Sum(x, y: TComplex) : TComplex;
begin
with result do
begin
r:= x.r + y.r;
i:= x.i + y.i;
end;
end;
function Difference(x, y: TComplex) : TComplex;
begin
with result do
begin
r:= x.r - y.r;
i:= x.i - y.i;
end;
end;
function EiT(t: TReal): TComplex;
begin
with result do
begin
r:= cos(t);
i:= sin(t);
end;
end;
function Product(x, y: TComplex): TComplex;
begin
with result do
begin
r:= x.r * y.r - x.i * y.i;
i:= x.r * y.i + x.i * y.r;
end;
end;
function TimesReal(x: TComplex; y: TReal): TComplex;
begin
with result do
begin
r:= x.r * y;
i:= x.i * y;
end;
end;
function PlusReal(x: TComplex; y: TReal): TComplex;
begin
with result do
begin
r:= x.r + y;
i:= x.i;
end;
end;
function ComplexToStr(x: TComplex): string;
begin
result:= FloatToStr(x.r)
+ ' + '
+ FloatToStr(x.i)
+ 'i';
end;
function AbsSquared(x: TComplex): TReal;
begin
result:= x.r*x.r + x.i*x.i;
end;
end.
unit cplxfft1;
interface
uses Cplx;
type
PScalar = ^TScalar;
TScalar = TComplex; {Making conversion to real version easier}
PScalars = ^TScalars;
TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
of TScalar;
const
TrigTableDepth: word = 0;
TrigTable : PScalars = nil;
procedure InitTrigTable(Depth: word);
procedure FFT(Depth: word;
Src: PScalars;
Dest: PScalars);
{REQUIRES allocating
(integer(1) shl Depth) * SizeOf(TScalar)
bytes for Src and Dest before call!}
implementation
procedure DoFFT(Depth: word;
Src: PScalars;
SrcSpacing: word;
Dest: PScalars);
{the recursive part called by FFT when ready}
var j, N: integer; Temp: TScalar; Shift: word;
begin
if Depth = 0 then
begin
Dest^[0]:= Src^[0];
exit;
end;
N:= integer(1) shl (Depth - 1);
DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);
DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N] );
Shift:= TrigTableDepth - Depth;
for j:= 0 to N - 1 do
begin
Temp:= Product(TrigTable^[j shl Shift],
Dest^[j + N]);
Dest^[j + N]:= Difference(Dest^[j], Temp);
Dest^[j] := Sum(Dest^[j], Temp);
end;
end;
procedure FFT(Depth: word;
Src: PScalars;
Dest: PScalars);
var j, N: integer; Normalizer: extended;
begin
N:= integer(1) shl depth;
if Depth TrigTableDepth then
InitTrigTable(Depth);
DoFFT(Depth, Src, 1, Dest);
Normalizer:= 1 / sqrt(N) ;
for j:=0 to N - 1 do
Dest^[j]:= TimesReal(Dest^[j], Normalizer);
end;
procedure InitTrigTable(Depth: word);
var j, N: integer;
begin
N:= integer(1) shl depth;
ReAllocMem(TrigTable, N * SizeOf(TScalar));
for j:=0 to N - 1 do
TrigTable^[j]:= EiT(-(2*Pi)*j/N);
TrigTableDepth:= Depth;
end;
initialization
;
finalization
ReAllocMem(TrigTable, 0);
end.
unit DemoForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses cplx, cplxfft1, MMSystem;
procedure TForm1.Button1Click(Sender: TObject);
var j: integer; s:string;
src, dest: PScalars;
norm: extended;
d,N,count:integer;
st,et: longint;
begin
d:= StrToIntDef(edit1.text, -1) ;
if d <1 then
raise exception.Create('depth must be a positive integer');
N:= integer(1) shl d ;
GetMem(Src, N*Sizeof(TScalar));
GetMem(Dest, N*SizeOf(TScalar));
for j:=0 to N-1 do
begin
src^[j]:= MakeComplex(random, random);
end;
begin
st:= timeGetTime;
FFT(d, Src, dest);
et:= timeGetTime;
end;
Memo1.Lines.Add('N = ' + IntToStr(N));
Memo1.Lines.Add('expected norm: ' +#9+ FloatToStr(N*2/3));
norm:=0;
for j:=0 to N-1 do norm:= norm + AbsSquared(src^[j]);
Memo1.Lines.Add('Data norm: '+#9+FloatToStr(norm));
norm:=0;
for j:=0 to N-1 do norm:= norm + AbsSquared(dest^[j]);
Memo1.Lines.Add('FT norm: '+#9#9+FloatToStr(norm));
Memo1.Lines.Add('Time in FFT routine: '+#9
+ inttostr(et - st)
+ ' ms.');
Memo1.Lines.Add(' ');
FreeMem(Src);
FreeMem(DEst);
end;
end.
**** The real version:
****
unit cplxfft2;
interface
type
PScalar = ^TScalar;
TScalar = extended;
PScalars = ^TScalars;
TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
of TScalar;
const
TrigTableDepth: word = 0;
CosTable : PScalars = nil;
SinTable : PScalars = nil;
procedure InitTrigTables(Depth: word);
procedure FFT(Depth: word;
SrcR, SrcI: PScalars;
DestR, DestI: PScalars);
{REQUIRES allocating
(integer(1) shl Depth) * SizeOf(TScalar)
bytes for SrcR, SrcI, DestR and DestI before call!}
implementation
procedure DoFFT(Depth: word;
SrcR, SrcI: PScalars;
SrcSpacing: word;
DestR, DestI: PScalars);
{the recursive part called by FFT when ready}
var j, N: integer;
TempR, TempI: TScalar;
Shift: word;
c, s: extended;
begin
if Depth = 0 then
begin
DestR^[0]:= SrcR^[0];
DestI^[0]:= SrcI^[0];
exit;
end;
N:= integer(1) shl (Depth - 1);
DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);
DoFFT(Depth - 1,
@SrcR^[srcSpacing],
@SrcI^[SrcSpacing],
SrcSpacing * 2,
@DestR^[N],
@DestI^[N]);
Shift:= TrigTableDepth - Depth;
for j:= 0 to N - 1 do
begin
c:= CosTable^[j shl Shift];
s:= SinTable^[j shl Shift];
TempR:= c * DestR^[j + N] - s * DestI^[j + N];
TempI:= c * DestI^[j + N] + s * DestR^[j + N];
DestR^[j + N]:= DestR^[j] - TempR;
DestI^[j + N]:= DestI^[j] - TempI;
DestR^[j]:= DestR^[j] + TempR;
DestI^[j]:= DestI^[j] + TempI;
end;
end;
procedure FFT(Depth: word;
SrcR, SrcI: PScalars;
DestR, DestI: PScalars);
var j, N: integer; Normalizer: extended;
begin
N:= integer(1) shl depth;
if Depth TrigTableDepth then
InitTrigTables(Depth);
DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);
Normalizer:= 1 / sqrt(N) ;
for j:=0 to N - 1 do
begin
DestR^[j]:= DestR^[j] * Normalizer;
DestI^[j]:= DestI^[j] * Normalizer;
end;
end;
procedure InitTrigTables(Depth: word);
var j, N: integer;
begin
N:= integer(1) shl depth;
ReAllocMem(CosTable, N * SizeOf(TScalar));
ReAllocMem(SinTable, N * SizeOf(TScalar));
for j:=0 to N - 1 do
begin
CosTable^[j]:= cos(-(2*Pi)*j/N);
SinTable^[j]:= sin(-(2*Pi)*j/N);
end;
TrigTableDepth:= Depth;
end;
initialization
;
finalization
ReAllocMem(CosTable, 0);
ReAllocMem(SinTable, 0);
end.
unit demofrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, cplxfft2, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses MMSystem;
procedure TForm1.Button1Click(Sender: TObject);
var SR, SI, DR, DI: PScalars;
j,d,N:integer;
st, et: longint;
norm: extended;
begin
d:= StrToIntDef(edit1.text, -1) ;
if d <1 then
raise exception.Create('depth must be a positive integer');
N:= integer(1) shl d;
GetMem(SR, N * SizeOf(TScalar));
GetMem(SI, N * SizeOf(TScalar));
GetMem(DR, N * SizeOf(TScalar));
GetMem(DI, N * SizeOf(TScalar));
for j:=0 to N - 1 do
begin
SR^[j]:=random;
SI^[j]:=random;
end;
st:= timeGetTime;
FFT(d, SR, SI, DR, DI);
et:= timeGetTime;
memo1.Lines.Add('N = '+inttostr(N));
memo1.Lines.Add('expected norm: '+#9+FloatToStr(N*2/3));
norm:=0;
for j:=0 to N - 1 do
norm:= norm + SR^[j]*SR^[j] + SI^[j]*SI^[j];
memo1.Lines.Add('Data norm: '+#9+FloatToStr(norm));
norm:=0;
for j:=0 to N - 1 do
norm:= norm + DR^[j]*DR^[j] + DI^[j]*DI^[j];
memo1.Lines.Add('FT norm: '+#9#9+FloatToStr(norm));
memo1.Lines.Add('Time in FFT routine: '+#9+inttostr(et-st));
memo1.Lines.add('');
(*for j:=0 to N - 1 do
Memo1.Lines.Add(FloatToStr(SR^[j])
+ ' + '
+ FloatToStr(SI^[j])
+ 'i');
for j:=0 to N - 1 do
Memo1.Lines.Add(FloatToStr(DR^[j])
+ ' + '
+ FloatToStr(DI^[j])
+ 'i');*)
FreeMem(SR, N * SizeOf(TScalar));
FreeMem(SI, N * SizeOf(TScalar));
FreeMem(DR, N * SizeOf(TScalar));
FreeMem(DI, N * SizeOf(TScalar));
end;
end.
From: renep@xs4all.nl (Rene Post)
lascaux@primenet.com (Martin Lapidus) wrote: >I need to draw to a Windows metafile. Delphi does not directly support this, >so I plan to use API calls to create the metafile. Creating a Metafile returns >a THandle which can be cast to a DC. >In delphi, how can I use the THandle to get/create a Canvas for drawing?I've asked a similar question a few days ago but got no response, so I figured it out myself. Here's the code. (hope it's what you need).
unit Metaform;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
BitBtn1: TBitBtn;
Image1: TImage;
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TMetafileCanvas = class(TCanvas)
private
FClipboardHandle: THandle;
FMetafileHandle: HMetafile;
FRect: TRect;
protected
procedure CreateHandle; override;
function GetMetafileHandle: HMetafile;
public
constructor Create;
destructor Destroy; override;
property Rect: TRect read FRect write FRect;
property MetafileHandle: HMetafile read GetMetafileHandle;
end;
constructor TMetafileCanvas.Create;
begin
inherited Create;
FClipboardHandle := GlobalAlloc(
GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
end;
destructor TMetafileCanvas.Destroy;
begin
DeleteMetafile(CloseMetafile(Handle));
if Bool(FClipboardHandle) then GlobalFree(FClipboardHandle);
if Bool(FMetafileHandle) then DeleteMetafile(FMetafileHandle);
inherited Destroy;
end;
procedure TMetafileCanvas.CreateHandle;
var
MetafileDC: HDC;
begin
{ Create a metafile DC in memory }
MetafileDC := CreateMetaFile(nil);
if Bool(MetafileDC) then
begin
{ Map the top,left corner of the displayed rectangle to the top,left of the
device context. Leave a border of 10 logical units around the picture. }
with FRect do SetWindowOrg(MetafileDC, Left - 10, Top - 10);
{ Set the extent of the picture with a border of 10 logical units. }
with FRect do SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
{ Play any valid metafile contents to it. }
if Bool(FMetafileHandle) then
begin
PlayMetafile(MetafileDC, FMetafileHandle);
end;
end;
Handle := MetafileDC;
end;
function TMetafileCanvas.GetMetafileHandle: HMetafile;
var
MetafilePict: PMetafilePict;
IC: HDC;
ExtRect: TRect;
begin
if Bool(FMetafileHandle) then DeleteMetafile(FMetafileHandle);
FMetafileHandle := CloseMetafile(Handle);
Handle := 0;
{ Prepair metafile for clipboard display. }
MetafilePict := GlobalLock(FClipboardHandle);
MetafilePict^.mm := mm_AnIsoTropic;
IC := CreateIC('DISPLAY', nil, nil, nil);
SetMapMode(IC, mm_HiMetric);
ExtRect := FRect;
DPtoLP(IC, ExtRect, 2);
DeleteDC(IC);
MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
MetafilePict^.HMF := FMetafileHandle;
GlobalUnlock(FClipboardHandle);
{ I'm giving you this handle, but please do NOT eat it. }
Result := FClipboardHandle;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
MetafileCanvas : TMetafileCanvas;
begin
MetafileCanvas := TMetafileCanvas.Create;
MetafileCanvas.Rect := Rect(0,0,500,500);
MetafileCanvas.Ellipse(10,10,400,400);
Image1.Picture.Metafile.LoadFromClipboardFormat(
cf_MetafilePict, MetafileCanvas.MetafileHandle, 0);
MetafileCanvas.Free;
end;
end.
From: Craig Francisco <Craig.Francisco@adm.monash.edu.au>
Try this:
procedure TScrnFrm.GrabScreen;
var
DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
ScrnForm.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);
ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;
unit Functs;
interface
uses
WinTypes, Classes, Graphics, SysUtils;
type
TPoint2D = record
X, Y: Real;
end;
TPoint3D = record
X, Y, Z: Real;
end;
function Point2D(X, Y: Real): TPoint2D;
function RoundPoint(P: TPoint2D): TPoint;
function FloatPoint(P: TPoint): TPoint2D;
function Point3D(X, Y, Z: Real): TPoint3D;
function Angle2D(P: TPoint2D): Real;
function Dist2D(P: TPoint2D): Real;
function Dist3D(P: TPoint3D): Real;
function RelAngle2D(PA, PB: TPoint2D): Real;
function RelDist2D(PA, PB: TPoint2D): Real;
function RelDist3D(PA, PB: TPoint3D): Real;
procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
function Dist2P(P, P1, P2: TPoint2D): Real;
function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
function SubPoints(P1, P2: TPoint2D): TPoint2D;
function Invert(Col: TColor): TColor;
function Dark(Col: TColor; Percentage: Byte): TColor;
function Light(Col: TColor; Percentage: Byte): TColor;
function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
function MMix(Cols: array of TColor): TColor;
function Log(Base, Value: Real): Real;
function Modulator(Val, Max: Real): Real;
function M(I, J: Integer): Integer;
function Tan(Angle2D: Real): Real;
procedure Limit(var Value: Integer; Min, Max: Integer);
function Exp2(Exponent: Byte): Word;
function GetSysDir: String;
function GetWinDir: String;
implementation
function Point2D(X, Y: Real): TPoint2D;
begin
Point2D.X := X;
Point2D.Y := Y;
end;
function RoundPoint(P: TPoint2D): TPoint;
begin
RoundPoint.X := Round(P.X);
RoundPoint.Y := Round(P.Y);
end;
function FloatPoint(P: TPoint): TPoint2D;
begin
FloatPoint.X := P.X;
FloatPoint.Y := P.Y;
end;
function Point3D(X, Y, Z: Real): TPoint3D;
begin
Point3D.X := X;
Point3D.Y := Y;
Point3D.Z := Z;
end;
function Angle2D(P: TPoint2D): Real;
begin
if P.X = 0 then
begin
if P.Y > 0 then Result := Pi / 2;
if P.Y = 0 then Result := 0;
if P.Y < 0 then Result := Pi / -2;
end
else
Result := Arctan(P.Y / P.X);
if P.X < 0 then
begin
if P.Y < 0 then Result := Result + Pi;
if P.Y >= 0 then Result := Result - Pi;
end;
If Result < 0 then Result := Result + 2 * Pi;
end;
function Dist2D(P: TPoint2D): Real;
begin
Result := Sqrt(P.X * P.X + P.Y * P.Y);
end;
function Dist3D(P: TPoint3D): Real;
begin
Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);
end;
function RelAngle2D(PA, PB: TPoint2D): Real;
begin
RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;
function RelDist2D(PA, PB: TPoint2D): Real;
begin
Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;
function RelDist3D(PA, PB: TPoint3D): Real;
begin
RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
end;
procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);
Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);
P := Temp;
end;
procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
var
Temp: TPoint2D;
begin
Temp := SubPoints(P, PCentr);
Rotate2D(Temp, Angle2D);
P := AddPoints(Temp, PCentr);
end;
procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X + (Cos(Angle2D) * Distance);
Temp.Y := P.Y + (Sin(Angle2D) * Distance);
P := Temp;
end;
function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
begin
Between.X := PA.X * Preference + PB.X * (1 - Preference);
Between.Y := PA.Y * Preference + PB.Y * (1 - Preference);
end;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
begin
Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
end;
function Dist2P(P, P1, P2: TPoint2D): Real;
begin
Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
end;
function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
begin
Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
end;
function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
begin
Result := False;
if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P2, P) <= 0 then
if Abs(Dist2P(P, P1, P2)) < D then Result := True;
end;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
begin
AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
end;
function SubPoints(P1, P2: TPoint2D): TPoint2D;
begin
SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
end;
function Invert(Col: TColor): TColor;
begin
Invert := not Col;
end;
function Dark(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col);
R := Round(R * Percentage / 100);
G := Round(G * Percentage / 100);
B := Round(B * Percentage / 100);
Dark := RGB(R, G, B);
end;
function Light(Col: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B := GetBValue(Col);
R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255);
G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255);
B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255);
Light := RGB(R, G, B);
end;
function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 - Percentage) / 100));
G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 - Percentage) / 100));
B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 - Percentage) / 100));
Mix := RGB(R, G, B);
end;
function MMix(Cols: array of TColor): TColor;
var
I, R, G, B, Length: Integer;
begin
Length := High(Cols) - Low(Cols) + 1;
R := 0; G := 0; B := 0;
for I := Low(Cols) to High(Cols) do
begin
R := R + GetRValue(Cols[I]);
G := G + GetGValue(Cols[I]);
B := B + GetBValue(Cols[I]);
end;
R := R div Length;
G := G div Length;
B := B div Length;
MMix := RGB(R, G, B);
end;
function Log(Base, Value: Real): Real;
begin
Log := Ln(Value) / Ln(Base);
end;
function Power(Base, Exponent: Real): Real;
begin
Power := Ln(Base) * Exp(Exponent);
end;
function Modulator(Val, Max: Real): Real;
begin
Modulator := (Val / Max - Round(Val / Max)) * Max;
end;
function M(I, J: Integer): Integer;
begin
M := ((I mod J) + J) mod J;
end;
function Tan(Angle2D: Real): Real;
begin
Tan := Sin(Angle2D) / Cos(Angle2D);
end;
procedure Limit(var Value: Integer; Min, Max: Integer);
begin
if Value < Min then Value := Min;
if Value > Max then Value := Max;
end;
function Exp2(Exponent: Byte): Word;
var
Temp, I: Word;
begin
Temp := 1;
for I := 1 to Exponent do
Temp := Temp * 2;
Result := Temp;
end;
function GetSysDir: String;
var
Temp: array[0..255] of Char;
begin
GetSystemDirectory(Temp, 256);
Result := StrPas(Temp);
end;
function GetWinDir: String;
var
Temp: array[0..255] of Char;
begin
GetWindowsDirectory(Temp, 256);
Result := StrPas(Temp);
end;
end.
Please email me and tell me if you liked this page.
|
This page has been created with |
|
