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.
Using the standard Windows API:
use hWnd := GetDesktopWindow to get the Handle to the 'desktop' ;
use hDC := GetDC (hWnd) to get the HDC (handle to a display context) ;
be sure to free the (release the handle of) hDC when you're done with it.
As a TCanvas.Handle is the HDC, you can use regular WinAPI to draw to it etc., or it may be possible to supply the HDC to the Handle property of a TCanvas you create.
[Chris Means, cmeans@intfar.com]
In D1 (should work for D2 also) try this:
I put a TPaintBox object and a TButton on my form.
procedure TForm1.Button1Click(Sender: TObject); var DeskTop : TCanvas ; begin DeskTop := TCanvas.Create ; try with DeskTop do Handle := GetWindowDC (GetDesktopWindow) ; with PaintBox1.Canvas do CopyRect (Rect (0, 0, 200, 200), DeskTop, Rect (0, 0, 200, 200)) finally DeskTop.Free end end;
The new unit has three routines: RotateBitmap90DegreesClockwise, RotateBitmap90DegreesCounterClockwise, and RotateBitmap180Degrees. All three take a TBitmap as a var and rotate it the appropriate way.
Two caveats: This still doesn't quite work for Delphi3. Somehow some noise gets introduced into the edges. I think it might be a bug in TBitmap's LoadFromStream method, but it's probably my fault. However, there are other solutions using the ScanLine property, so that isn't much of a problem. Second, this doesn't work if the bitmap is RLE compressed. 4- and 8-byte bitmaps can be run-length encoded, and they will be stored that way in memory until a handle is needed. If the bitmap is compressed, just grab the canvas's handle
ABitmap.Canvas.Handle;
Anyway, the unit I'm attaching works in Delphi 1 and 2 for monochrome, 4-, 8-, 16-, 24-, and 32-bit bitmaps (but not for 4- and 8-bit RLE compressed guys, as I mentioned above).
unit bmpRot; interface uses (*$IFDEF Win32*) Windows, (*$ELSE*) WinTypes, WinProcs, (*$ENDIF*) Classes, Graphics; procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap); procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap); procedure RotateBitmap180Degrees(var ABitmap: TBitmap); implementation uses Dialogs; (*$IFNDEF Win32*) type DWORD = LongInt; TSelOfs = record L, H: Word; end; procedure Win16Dec(var P: Pointer; const N: LongInt); forward; procedure Win16Inc(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Dec(P, -N) else if N > 0 then begin Inc( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); Inc( TSelOfs(P).L, TSelOfs(N).L ); if TSelOfs(P).L < TSelOfs(N).L then Inc( TSelOfs(P).H, SelectorInc ); end; end; procedure Win16Dec(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Inc(P, -N) else if N > 0 then begin if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc ); Dec( TSelOfs(P).L, TSelOfs(N).L ); Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); end; end; (* procedure HugeShift; far; external 'KERNEL' index 113; procedure Win16Dec(var P: Pointer; const N: LongInt); forward; procedure Win16Inc(var HugePtr: Pointer; Amount: LongInt); procedure HugeInc; assembler; asm mov ax, Amount.Word[0] { Store Amount in DX:AX. } mov dx, Amount.Word[2] les bx, HugePtr { Get the reference to HugePtr. } add ax, es:[bx] { Add the offset parts. } adc dx, 0 { Propagate carry to the high word of Amount. } mov cx, Offset HugeShift shl dx, cl { Shift high word of Amount for segment. } add es:[bx+2], dx { Increment the segment of HugePtr. } mov es:[bx], ax end; begin if Amount > 0 then HugeInc else if Amount < 0 then Win16Dec(HugePtr, -Amount); end; procedure Win16Dec(var P: Pointer; const N: LongInt); begin if N < 0 then Win16Inc(P, -N) else if N > 0 then begin if TSelOfs(N).L > TSelOfs(P).L then Dec( TSelOfs(P).H, SelectorInc ); Dec( TSelOfs(P).L, TSelOfs(N).L ); Dec( TSelOfs(P).H, TSelOfs(N).H * SelectorInc ); end; end; *) (*$ENDIF*) procedure RotateBitmap90DegreesCounterClockwise(var ABitmap: TBitmap); const BitsPerByte = 8; var { A whole pile of variables. Some deal with one- and four-bit bitmaps only, some deal with eight- and 24-bit bitmaps only, and some deal with both. Any variable that ends in 'R' refers to the rotated bitmap, e.g. MemoryStream holds the original bitmap, and MemoryStreamR holds the rotated one. } PbmpInfoR: PBitmapInfoHeader; bmpBuffer, bmpBufferR: PByte; MemoryStream, MemoryStreamR: TMemoryStream; PbmpBuffer, PbmpBufferR: PByte; BytesPerPixel, PixelsPerByte: LongInt; BytesPerScanLine, BytesPerScanLineR: LongInt; PaddingBytes: LongInt; BitmapOffset: LongInt; BitCount: LongInt; WholeBytes, ExtraPixels: LongInt; SignificantBytes, SignificantBytesR: LongInt; ColumnBytes: LongInt; AtLeastEightBitColor: Boolean; T: LongInt; procedure NonIntegralByteRotate; (* nested *) { This routine rotates bitmaps with fewer than 8 bits of information per pixel, namely monochrome (1-bit) and 16-color (4-bit) bitmaps. Note that there are no such things as 2-bit bitmaps, though you might argue that Microsoft's bitmap format is worth about 2 bits. } var X, Y: LongInt; I: LongInt; MaskBits, CurrentBits: Byte; FirstMask, LastMask: Byte; PFirstScanLine: PByte; FirstIndex, CurrentBitIndex: LongInt; ShiftRightAmount, ShiftRightStart: LongInt; begin (*$IFDEF Win32*) Inc(PbmpBuffer, BytesPerScanLine * (PbmpInfoR^.biHeight - 1) ); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), BytesPerScanLine * (PbmpInfoR^.biHeight - 1) ); (*$ENDIF*) { PFirstScanLine advances along the first scan line of bmpBufferR. } PFirstScanLine := bmpBufferR; { Set up the indexing. } FirstIndex := BitsPerByte - BitCount; { Set up the bit masks: For a monochrome bitmap, LastMask := 00000001 and FirstMask := 10000000 For a 4-bit bitmap, LastMask := 00001111 and FirstMask := 11110000 We'll shift through these such that the CurrentBits and the MaskBits will go For a monochrome bitmap: 10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001 For a 4-bit bitmap: 11110000, 00001111 The CurrentBitIndex denotes how far over the right-most bit would need to shift to get to the position of CurrentBits. For example, if we're on the eleventh column of a monochrome bitmap, then CurrentBits will equal 11 mod 8 := 3, or the 3rd-to-the-leftmost bit. Thus, the right-most bit would need to shift four places over to get anded correctly with CurrentBits. CurrentBitIndex will store this value. } LastMask := 1 shl BitCount - 1; FirstMask := LastMask shl FirstIndex; CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; ShiftRightStart := BitCount * (PixelsPerByte - 1); { Here's the meat. Loop through the pixels and rotate appropriately. } { Remember that DIBs have their origins opposite from DDBs. } { The Y counter holds the current row of the source bitmap. } for Y := 1 to PbmpInfoR^.biHeight do begin PbmpBufferR := PFirstScanLine; { The X counter holds the current column of the source bitmap. We only deal with completely filled bytes here. Should there be an extra 'partial' byte, we'll deal with that below. } for X := 1 to WholeBytes do begin { Pick out the bits, starting with 10000000 for monochromes and 11110000 for 4-bit guys. } MaskBits := FirstMask; { ShiftRightAmount is the amount we need to shift the current bit all the way to the right. } ShiftRightAmount := ShiftRightStart; for I := 1 to PixelsPerByte do begin { Here's the doozy. Take the rotated bitmap's current byte and mask it with not CurrentBits. This zeros out the CurrentBits only, and leaves everything else unchanged. Example: For a monochrome bitmap, if we were on the 11th column as above, we would need to zero out the 3rd-to-left bit, so we would take PbmpBufferR^ and 11011111. Now consider our current source byte. For monochrome bitmaps, we're going to loop through each bit, for a total of eight pixels. For 4-bit bitmaps, we're going to loop through the bits four at a time, for a total of two pixels. Either way, we do this by masking it with MaskBits ('PbmpBuffer^ and MaskBits'). Now we need to get the bit(s) into the same column(s) that CurrentBits reflects. We do this by shifting them to the right-most part of the byte ('shr ShiftRightAmount'), and then shifting left by our aforementioned CurrentBitIndex ('shl CurrentBitIndex'). This is because, although a right-shift of -n should just be a left-shift of +n, it doesn't work that way, at least in Delphi. So we just start from scratch by putting everything as far right as we can. Finally, we have our source bit(s) shifted to the appropriate place, with nothing but zeros around. Simply or it with PbmpBufferR^ (which had its CurrentBits zeroed out, remember?) and we're done. Yeah, sure. "Simply". Duh. } PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); { Move the MaskBits over for the next iteration. } MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) { Move our pointer to the rotated-bitmap buffer up one scan line. } Inc(PbmpBufferR, BytesPerScanLineR); { We don't need to shift as far to the right the next time around. } Dec(ShiftRightAmount, BitCount); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR ); Win16Dec( Pointer(ShiftRightAmount), BitCount ); (*$ENDIF*) end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { If there's a partial byte, take care of it now. } if ExtraPixels <> 0 then begin { Do exactly the same crap as in the loop above. } MaskBits := FirstMask; ShiftRightAmount := ShiftRightStart; for I := 1 to ExtraPixels do begin PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) Inc(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; (*$IFDEF Win32*) { Skip the padding. } Inc(PbmpBuffer, PaddingBytes); { Back up the scan line you just traversed, and go one more to get set for the next row. } Dec(PbmpBuffer, BytesPerScanLine shl 1); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); Win16Dec( Pointer(PbmpBuffer), BytesPerScanLine shl 1 ); (*$ENDIF*) if CurrentBits = LastMask then begin { We're at the end of this byte. Start over on another column. } CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; { Go to the bottom of the rotated bitmap's column, but one column over. } (*$IFDEF Win32*) Inc(PFirstScanLine); (*$ELSE*) Win16Inc( Pointer(PFirstScanLine), 1 ); (*$ENDIF*) end else begin { Continue filling this byte. } CurrentBits := CurrentBits shr BitCount; Dec(CurrentBitIndex, BitCount); end; end; end; { procedure NonIntegralByteRotate (* nested *) } procedure IntegralByteRotate; (* nested *) var X, Y: LongInt; (*$IFNDEF Win32*) I: Integer; (*$ENDIF*) begin { Advance PbmpBufferR to the last column of the first scan line of bmpBufferR. } (*$IFDEF Win32*) Inc(PbmpBufferR, SignificantBytesR - BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SignificantBytesR - BytesPerPixel ); (*$ENDIF*) { Here's the meat. Loop through the pixels and rotate appropriately. } { Remember that DIBs have their origins opposite from DDBs. } for Y := 1 to PbmpInfoR^.biHeight do begin for X := 1 to PbmpInfoR^.biWidth do begin { Copy the pixels. } (*$IFDEF Win32*) Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel); Inc(PbmpBuffer, BytesPerPixel); Inc(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) for I := 1 to BytesPerPixel do begin PbmpBufferR^ := PbmpBuffer^; Win16Inc( Pointer(PbmpBuffer), 1 ); Win16Inc( Pointer(PbmpBufferR), 1 ); end; Win16Inc( Pointer(PbmpBufferR), BytesPerScanLineR - BytesPerPixel); (*$ENDIF*) end; (*$IFDEF Win32*) { Skip the padding. } Inc(PbmpBuffer, PaddingBytes); { Go to the top of the rotated bitmap's column, but one column over. } Dec(PbmpBufferR, ColumnBytes + BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes); Win16Dec( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel); (*$ENDIF*) end; end; { This is the body of procedure RotateBitmap90DegreesCounterClockwise. } begin { Don't *ever* call GetDIBSizes! It screws up your bitmap. } MemoryStream := TMemoryStream.Create; { To do: Set the size before-hand. This will eliminate ReAlloc overhead for the MemoryStream. Calling GetDIBSizes would be nice, but, as mentioned above, it corrupts the Bitmap in some cases. Some API calls will probably take care of things, but I'm not going to mess with it right now. } { An undocumented method. Nice to have around, though. } ABitmap.SaveToStream(MemoryStream); { Don't need you anymore. We'll make a new one when the time comes. } ABitmap.Free; bmpBuffer := MemoryStream.Memory; { Get the offset bits. This may or may not include palette information. } BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits; { Set PbmpInfoR to point to the source bitmap's info header. } { Boy, these headers are getting annoying. } (*$IFDEF Win32*) Inc( bmpBuffer, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(bmpBuffer); { Set bmpBuffer and PbmpBuffer to point to the original bitmap bits. } bmpBuffer := MemoryStream.Memory; (*$IFDEF Win32*) Inc(bmpBuffer, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), BitmapOffset ); (*$ENDIF*) PbmpBuffer := bmpBuffer; { Note that we don't need to worry about version 4 vs. version 3 bitmaps, because the fields we use -- namely biWidth, biHeight, and biBitCount -- occur in exactly the same place in both structs. So we're a bit lucky. OS/2 bitmaps, by the way, cause this to crash heinously. Sorry. } with PbmpInfoR^ do begin { ShowMessage('Compression := ' + IntToStr(biCompression)); } BitCount := biBitCount; { ShowMessage('BitCount := ' + IntToStr(BitCount)); } { ScanLines are DWORD aligned. } BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD)); BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD)); AtLeastEightBitColor := BitCount >= BitsPerByte; if AtLeastEightBitColor then begin { Don't have to worry about bit-twiddling. Cool. } BytesPerPixel := biBitCount shr 3; SignificantBytes := biWidth * BitCount shr 3; SignificantBytesR := biHeight * BitCount shr 3; { Extra bytes required for DWORD aligning. } PaddingBytes := BytesPerScanLine - SignificantBytes; ColumnBytes := BytesPerScanLineR * biWidth; end else begin { One- or four-bit bitmap. Ugh. } PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount; { The number of bytes entirely filled with pixel information. } WholeBytes := biWidth div PixelsPerByte; { Any extra bits that might partially fill a byte. For instance, a monochrome bitmap that is 14 pixels wide has one whole byte and a partial byte which has six bits actually used (the rest are garbage). } ExtraPixels := biWidth mod PixelsPerByte; { The number of extra bytes -- if any -- required to DWORD-align a scanline. } PaddingBytes := BytesPerScanLine - WholeBytes; { If there are extra bits (i.e., they run over into a 'partial byte'), then one of the padding bytes has already been accounted for. } if ExtraPixels <> 0 then Dec(PaddingBytes); end; { if AtLeastEightBitColor then } { The TMemoryStream that will hold the rotated bits. } MemoryStreamR := TMemoryStream.Create; { Set size for rotated bitmap. Might be different from source size due to DWORD aligning. } MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth); end; { with PbmpInfoR^ do } { Copy the headers from the source bitmap. } MemoryStream.Seek(0, soFromBeginning); MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset); { Here's the buffer we're going to rotate. } bmpBufferR := MemoryStreamR.Memory; { Skip the headers, yadda yadda yadda... } (*$IFDEF Win32*) Inc(bmpBufferR, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBufferR), BitmapOffset ); (*$ENDIF*) PbmpBufferR := bmpBufferR; { Do it. } if AtLeastEightBitColor then IntegralByteRotate else NonIntegralByteRotate; { Done with the source bits. } MemoryStream.Free; { Now set PbmpInfoR to point to the rotated bitmap's info header. } PbmpBufferR := MemoryStreamR.Memory; (*$IFDEF Win32*) Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(PbmpBufferR); { Swap the width and height of the rotated bitmap's info header. } with PbmpInfoR^ do begin T := biHeight; biHeight := biWidth; biWidth := T; biSizeImage := 0; end; ABitmap := TBitmap.Create; { Spin back to the very beginning. } MemoryStreamR.Seek(0, soFromBeginning); { Load it back into ABitmap. } ABitmap.LoadFromStream(MemoryStreamR); MemoryStreamR.Free; end; procedure RotateBitmap90DegreesClockwise(var ABitmap: TBitmap); const BitsPerByte = 8; var { A whole pile of variables. Some deal with one- and four-bit bitmaps only, some deal with eight- and 24-bit bitmaps only, and some deal with both. Any variable that ends in 'R' refers to the rotated bitmap, e.g. MemoryStream holds the original bitmap, and MemoryStreamR holds the rotated one. } PbmpInfoR: PBitmapInfoHeader; bmpBuffer, bmpBufferR: PByte; MemoryStream, MemoryStreamR: TMemoryStream; PbmpBuffer, PbmpBufferR: PByte; BytesPerPixel, PixelsPerByte: LongInt; BytesPerScanLine, BytesPerScanLineR: LongInt; PaddingBytes: LongInt; BitmapOffset: LongInt; BitCount: LongInt; WholeBytes, ExtraPixels: LongInt; SignificantBytes: LongInt; ColumnBytes: LongInt; AtLeastEightBitColor: Boolean; T: LongInt; procedure NonIntegralByteRotate; (* nested *) { This routine rotates bitmaps with fewer than 8 bits of information per pixel, namely monochrome (1-bit) and 16-color (4-bit) bitmaps. Note that there are no such things as 2-bit bitmaps, though you might argue that Microsoft's bitmap format is worth about 2 bits. } var X, Y: LongInt; I: LongInt; MaskBits, CurrentBits: Byte; FirstMask, LastMask: Byte; PLastScanLine: PByte; FirstIndex, CurrentBitIndex: LongInt; ShiftRightAmount, ShiftRightStart: LongInt; begin { Advance PLastScanLine to the first column of the last scan line of bmpBufferR. } PLastScanLine := bmpBufferR; (*$IFDEF Win32*) Inc(PLastScanLine, BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ELSE*) Win16Inc( Pointer(PLastScanLine), BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ENDIF*) { Set up the indexing. } FirstIndex := BitsPerByte - BitCount; { Set up the bit masks: For a monochrome bitmap, LastMask := 00000001 and FirstMask := 10000000 For a 4-bit bitmap, LastMask := 00001111 and FirstMask := 11110000 We'll shift through these such that the CurrentBits and the MaskBits will go For a monochrome bitmap: 10000000, 01000000, 00100000, 00010000, 00001000, 00000100, 00000010, 00000001 For a 4-bit bitmap: 11110000, 00001111 The CurrentBitIndex denotes how far over the right-most bit would need to shift to get to the position of CurrentBits. For example, if we're on the eleventh column of a monochrome bitmap, then CurrentBits will equal 11 mod 8 := 3, or the 3rd-to-the-leftmost bit. Thus, the right-most bit would need to shift four places over to get anded correctly with CurrentBits. CurrentBitIndex will store this value. } LastMask := 1 shl BitCount - 1; FirstMask := LastMask shl FirstIndex; CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; ShiftRightStart := BitCount * (PixelsPerByte - 1); { Here's the meat. Loop through the pixels and rotate appropriately. } { Remember that DIBs have their origins opposite from DDBs. } { The Y counter holds the current row of the source bitmap. } for Y := 1 to PbmpInfoR^.biHeight do begin PbmpBufferR := PLastScanLine; { The X counter holds the current column of the source bitmap. We only deal with completely filled bytes here. Should there be an extra 'partial' byte, we'll deal with that below. } for X := 1 to WholeBytes do begin { Pick out the bits, starting with 10000000 for monochromes and 11110000 for 4-bit guys. } MaskBits := FirstMask; { ShiftRightAmount is the amount we need to shift the current bit all the way to the right. } ShiftRightAmount := ShiftRightStart; for I := 1 to PixelsPerByte do begin { Here's the doozy. Take the rotated bitmap's current byte and mask it with not CurrentBits. This zeros out the CurrentBits only, and leaves everything else unchanged. Example: For a monochrome bitmap, if we were on the 11th column as above, we would need to zero out the 3rd-to-left bit, so we would take PbmpBufferR^ and 11011111. Now consider our current source byte. For monochrome bitmaps, we're going to loop through each bit, for a total of eight pixels. For 4-bit bitmaps, we're going to loop through the bits four at a time, for a total of two pixels. Either way, we do this by masking it with MaskBits ('PbmpBuffer^ and MaskBits'). Now we need to get the bit(s) into the same column(s) that CurrentBits reflects. We do this by shifting them to the right-most part of the byte ('shr ShiftRightAmount'), and then shifting left by our aforementioned CurrentBitIndex ('shl CurrentBitIndex'). This is because, although a right-shift of -n should just be a left-shift of +n, it doesn't work that way, at least in Delphi. So we just start from scratch by putting everything as far right as we can. Finally, we have our source bit(s) shifted to the appropriate place, with nothing but zeros around. Simply or it with PbmpBufferR^ (which had its CurrentBits zeroed out, remember?) and we're done. Yeah, sure. "Simply". Duh. } PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); { Move the MaskBits over for the next iteration. } MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) { Move our pointer to the rotated-bitmap buffer up one scan line. } Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) { We don't need to shift as far to the right the next time around. } Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { If there's a partial byte, take care of it now. } if ExtraPixels <> 0 then begin { Do exactly the same crap as in the loop above. } MaskBits := FirstMask; ShiftRightAmount := ShiftRightStart; for I := 1 to ExtraPixels do begin PbmpBufferR^ := ( PbmpBufferR^ and not CurrentBits ) or ( (PbmpBuffer^ and MaskBits) shr ShiftRightAmount shl CurrentBitIndex ); MaskBits := MaskBits shr BitCount; (*$IFDEF Win32*) Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR ); (*$ENDIF*) Dec(ShiftRightAmount, BitCount); end; (*$IFDEF Win32*) Inc(PbmpBuffer); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), 1 ); (*$ENDIF*) end; { Skip the padding. } (*$IFDEF Win32*) Inc(PbmpBuffer, PaddingBytes); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); (*$ENDIF*) if CurrentBits = LastMask then begin { We're at the end of this byte. Start over on another column. } CurrentBits := FirstMask; CurrentBitIndex := FirstIndex; { Go to the bottom of the rotated bitmap's column, but one column over. } (*$IFDEF Win32*) Inc(PLastScanLine); (*$ELSE*) Win16Inc( Pointer(PLastScanLine), 1 ); (*$ENDIF*) end else begin { Continue filling this byte. } CurrentBits := CurrentBits shr BitCount; Dec(CurrentBitIndex, BitCount); end; end; end; { procedure NonIntegralByteRotate (* nested *) } procedure IntegralByteRotate; (* nested *) var X, Y: LongInt; (*$IFNDEF Win32*) I: Integer; (*$ENDIF*) begin { Advance PbmpBufferR to the first column of the last scan line of bmpBufferR. } (*$IFDEF Win32*) Inc( PbmpBufferR, BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR) , BytesPerScanLineR * (PbmpInfoR^.biWidth - 1) ); (*$ENDIF*) { Here's the meat. Loop through the pixels and rotate appropriately. } { Remember that DIBs have their origins opposite from DDBs. } for Y := 1 to PbmpInfoR^.biHeight do begin for X := 1 to PbmpInfoR^.biWidth do begin { Copy the pixels. } (*$IFDEF Win32*) Move(PbmpBuffer^, PbmpBufferR^, BytesPerPixel); Inc(PbmpBuffer, BytesPerPixel); Dec(PbmpBufferR, BytesPerScanLineR); (*$ELSE*) for I := 1 to BytesPerPixel do begin PbmpBufferR^ := PbmpBuffer^; Win16Inc( Pointer(PbmpBuffer), 1 ); Win16Inc( Pointer(PbmpBufferR), 1 ); end; Win16Dec( Pointer(PbmpBufferR), BytesPerScanLineR + BytesPerPixel); (*$ENDIF*) end; (*$IFDEF Win32*) { Skip the padding. } Inc(PbmpBuffer, PaddingBytes); { Go to the top of the rotated bitmap's column, but one column over. } Inc(PbmpBufferR, ColumnBytes + BytesPerPixel); (*$ELSE*) Win16Inc( Pointer(PbmpBuffer), PaddingBytes ); Win16Inc( Pointer(PbmpBufferR), ColumnBytes + BytesPerPixel ); (*$ENDIF*) end; end; { This is the body of procedure RotateBitmap90DegreesCounterClockwise. } begin { Don't *ever* call GetDIBSizes! It screws up your bitmap. } MemoryStream := TMemoryStream.Create; { To do: Set the size before-hand. This will eliminate ReAlloc overhead for the MemoryStream. Calling GetDIBSizes would be nice, but, as mentioned above, it corrupts the Bitmap in some cases. Some API calls will probably take care of things, but I'm not going to mess with it right now. } { An undocumented method. Nice to have around, though. } ABitmap.SaveToStream(MemoryStream); { Don't need you anymore. We'll make a new one when the time comes. } ABitmap.Free; bmpBuffer := MemoryStream.Memory; { Get the offset bits. This may or may not include palette information. } BitmapOffset := PBitmapFileHeader(bmpBuffer)^.bfOffBits; { Set PbmpInfoR to point to the source bitmap's info header. } { Boy, these headers are getting annoying. } (*$IFDEF Win32*) Inc( bmpBuffer, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(bmpBuffer); { Set bmpBuffer and PbmpBuffer to point to the original bitmap bits. } bmpBuffer := MemoryStream.Memory; (*$IFDEF Win32*) Inc(bmpBuffer, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBuffer), BitmapOffset ); (*$ENDIF*) PbmpBuffer := bmpBuffer; { Note that we don't need to worry about version 4 vs. version 3 bitmaps, because the fields we use -- namely biWidth, biHeight, and biBitCount -- occur in exactly the same place in both structs. So we're a bit lucky. OS/2 bitmaps, by the way, cause this to crash heinously. Sorry. } with PbmpInfoR^ do begin { ShowMessage('Compression := ' + IntToStr(biCompression)); } BitCount := biBitCount; { ShowMessage('BitCount := ' + IntToStr(BitCount)); } { ScanLines are DWORD aligned. } BytesPerScanLine := ((((biWidth * BitCount) + 31) div 32) * SizeOf(DWORD)); BytesPerScanLineR := ((((biHeight * BitCount) + 31) div 32) * SizeOf(DWORD)); AtLeastEightBitColor := BitCount >= BitsPerByte; if AtLeastEightBitColor then begin { Don't have to worry about bit-twiddling. Cool. } BytesPerPixel := biBitCount shr 3; SignificantBytes := biWidth * BitCount shr 3; { Extra bytes required for DWORD aligning. } PaddingBytes := BytesPerScanLine - SignificantBytes; ColumnBytes := BytesPerScanLineR * biWidth; end else begin { One- or four-bit bitmap. Ugh. } PixelsPerByte := SizeOf(Byte) * BitsPerByte div BitCount; { The number of bytes entirely filled with pixel information. } WholeBytes := biWidth div PixelsPerByte; { Any extra bits that might partially fill a byte. For instance, a monochrome bitmap that is 14 pixels wide has one whole byte and a partial byte which has six bits actually used (the rest are garbage). } ExtraPixels := biWidth mod PixelsPerByte; { The number of extra bytes -- if any -- required to DWORD-align a scanline. } PaddingBytes := BytesPerScanLine - WholeBytes; { If there are extra bits (i.e., they run over into a 'partial byte'), then one of the padding bytes has already been accounted for. } if ExtraPixels <> 0 then Dec(PaddingBytes); end; { if AtLeastEightBitColor then } { The TMemoryStream that will hold the rotated bits. } MemoryStreamR := TMemoryStream.Create; { Set size for rotated bitmap. Might be different from source size due to DWORD aligning. } MemoryStreamR.SetSize(BitmapOffset + BytesPerScanLineR * biWidth); end; { with PbmpInfoR^ do } { Copy the headers from the source bitmap. } MemoryStream.Seek(0, soFromBeginning); MemoryStreamR.CopyFrom(MemoryStream, BitmapOffset); { Here's the buffer we're going to rotate. } bmpBufferR := MemoryStreamR.Memory; { Skip the headers, yadda yadda yadda... } (*$IFDEF Win32*) Inc(bmpBufferR, BitmapOffset); (*$ELSE*) Win16Inc( Pointer(bmpBufferR), BitmapOffset ); (*$ENDIF*) PbmpBufferR := bmpBufferR; { Do it. } if AtLeastEightBitColor then IntegralByteRotate else NonIntegralByteRotate; { Done with the source bits. } MemoryStream.Free; { Now set PbmpInfoR to point to the rotated bitmap's info header. } PbmpBufferR := MemoryStreamR.Memory; (*$IFDEF Win32*) Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) ); (*$ELSE*) Win16Inc( Pointer(PbmpBufferR), SizeOf(TBitmapFileHeader) ); (*$ENDIF*) PbmpInfoR := PBitmapInfoHeader(PbmpBufferR); { Swap the width and height of the rotated bitmap's info header. } with PbmpInfoR^ do begin T := biHeight; biHeight := biWidth; biWidth := T; biSizeImage := 0; end; ABitmap := TBitmap.Create; { Spin back to the very beginning. } MemoryStreamR.Seek(0, soFromBeginning); { Load it back into ABitmap. } ABitmap.LoadFromStream(MemoryStreamR); MemoryStreamR.Free; end; procedure RotateBitmap180Degrees(var ABitmap: TBitmap); var RotatedBitmap: TBitmap; begin RotatedBitmap := TBitmap.Create; with RotatedBitmap do begin Width := ABitmap.Width; Height := ABitmap.Height; Canvas.StretchDraw( Rect(ABitmap.Width, ABitmap.Height, 0, 0), ABitmap ); end; ABitmap.Free; ABitmap := RotatedBitmap; end; end.
Since someone from Italy asked me for an example of using pf1bit Bitmaps, I thought I would post part of my response and add other details for pf8bit and pf24bit here in case others were wondering.
Background
The new Delphi 3 scanline property allows quick access to individual pixels, but you must know what Bitmap.PixelFormat you're working with before you can access the pixels.
Possible PixelFormats include:
For pf24bit bitmaps, I define (I wish Borland would)
CONST PixelCountMax = 32768; TYPE pRGBArray = ^TRGBArray; TRGBArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;
To step through a 24-bit bitmap and while creating a new one and access the 3-bytes-per-pixel data, use a construct like the following:
... VAR i : INTEGER; j : INTEGER; RowOriginal : pRGBArray; RowProcessed: pRGBArray; BEGIN IF OriginalBitmap.PixelFormat <> pf24bit THEN RAISE EImageProcessingError.Create('GetImageSpace: ' + 'Bitmap must be 24-bit color.'); {Step through each row of image.} FOR j := OriginalBitmap.Height-1 DOWNTO 0 DO BEGIN RowOriginal := pRGBArray(OriginalBitmap.Scanline[j]); RowProcessed := pRGBArray(ProcessedBitmap.Scanline[j]); FOR i := OriginalBitmap.Width-1 DOWNTO 0 DO BEGIN // Access individual color RGB color planes with references like: // RowProcessed[i].rgbtRed := RowOriginal[i].rgbtRed; // RowProcessed[i].rgbtGreen := RowOriginal[i].rgbtGreen; // RowProcessed[i].rgbtBlue := RowOriginal[i].rgbtBlue; END END ...
Access to these byte-per-pixel bitmaps is easy using the TByteArray (defined in SysUtils.PAS):
PByteArray = ^TByteArray; TByteArray = array[0..32767] of Byte;
PWordArray = ^TWordArray; TWordArray = array[0..16383] of Word; )
TYPE THistogram = ARRAY[0..255] OF INTEGER; ... VAR Histogram: THistogram; i : INTEGER; j : INTEGER; Row : pByteArray; ... FOR i := Low(THistogram) TO High(THistogram) DO Histogram[i] := 0; IF Bitmap.PixelFormat = pf8bit THEN BEGIN FOR j := Bitmap.Height-1 DOWNTO 0 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := Bitmap.Width-1 DOWNTO 0 DO BEGIN INC (Histogram[Row[i]]) END END END ...
Accessing pf8bit bitmaps is easy since they are one byte per pixel. But you can save a lot of memory if you only need a single bit per pixel (such as with various masks), if you use pf1bit Bitmaps.
As with pf8bit bitmaps, use a TByteArray to access pf1bit Scanlines. But you will need to perform bit operations on the bytes to access the various pixels. Also, the width of the Scanline is Bitmap.Width DIV 8 bytes.
The following code shows how to create the following kinds of 1-bit bitmaps: black, white, stripes, "g", "arrow" and random -- an "invert" option is also available. (Send me an E-mail if you'd like the complete working source code including the form.)
Create a form with an Image1: TImage on it -- I used 1 256x256 Image1 with Stretch := TRUE to see the individual pixels more easily. The buttons Black, White and Stripes have tags of 0, 255, and 85 ($55 = 01010101 binary) that call ButtonStripesClick when selected.
Buttons "g" and "arrow" call separate event handlers to draw these bitmaps taken form HP Laserjet examples.
"Random" just randomly sets bits on in the 1-bit bitmaps.
"Invert" changes all the 0s to 1's and vice versa.
// Example of how to use Bitmap.Scanline for PixelFormat=pf1Bit. // Requested by Mino Ballone from Italy. // // Copyright (C) 1997, Earl F. Glynn, Overland Park, KS. All rights reserved. // May be freely used for non-commerical purposes. unit ScreenSingleBit; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Image1: TImage; ButtonBlack: TButton; ButtonWhite: TButton; ButtonStripes: TButton; ButtonG: TButton; ButtonArrow: TButton; ButtonRandom: TButton; ButtonInvert: TButton; procedure ButtonStripesClick(Sender: TObject); procedure ButtonGClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure ButtonRandomClick(Sender: TObject); procedure ButtonInvertClick(Sender: TObject); procedure ButtonArrowClick(Sender: TObject); private Bitmap: TBitmap; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} CONST BitsPerPixel = 8; procedure TForm1.ButtonStripesClick(Sender: TObject); VAR i : INTEGER; j : INTEGER; Row : pByteArray; Value : BYTE; begin Value := (Sender AS TButton).Tag; // Value = $00 = 00000000 binary for black // Value = $FF = 11111111 binary for white // Value = $55 = 01010101 binary for black & white stripes FOR j := 0 TO Bitmap.Height-1 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO BEGIN Row[i] := Value END END; Image1.Picture.Graphic := Bitmap end; procedure TForm1.ButtonGClick(Sender: TObject); CONST {The "g" bitmap was adapted from the LaserJet IIP Printer Tech Ref Manual} G: ARRAY[0..31, 0..3] OF BYTE = { 0} ( ($00, $FC, $0F, $C0), {00000000 11111100 00001111 11000000} { 1} ($07, $FF, $1F, $E0), {00000111 11111111 00011111 11100000} { 2} ($0F, $FF, $9F, $C0), {00001111 11111111 10011111 11000000} { 3} ($3F, $D7, $DE, $00), {00111111 11010111 11011110 00000000} { 4} ($3E, $01, $FE, $00), {00111110 00000001 11111110 00000000} { 5} ($7C, $00, $7E, $00), {01111100 00000000 01111110 00000000} { 6} ($78, $00, $7E, $00), {01111000 00000000 01111110 00000000} { 7} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000} { 8} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000} { 9} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000} {10} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000} {11} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000} {12} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000} {13} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000} {14} ($78, $00, $3E, $00), {01111000 00000000 00111110 00000000} {15} ($78, $00, $3E, $00), {01111000 00000000 00111110 00000000} {16} ($78, $00, $7E, $00), {01111000 00000000 01111110 00000000} {17} ($3C, $00, $FE, $00), {00111100 00000000 11111110 00000000} {18} ($1F, $D7, $DE, $00), {00011111 11010111 11011110 00000000} {19} ($0F, $FF, $5E, $00), {00001111 11111111 10011110 00000000} {20} ($07, $FF, $1E, $00), {00000111 11111111 00011110 00000000} {21} ($00, $A8, $1E, $00), {00000000 10101000 00011110 00000000} {22} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000} {23} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000} {24} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000} {25} ($00, $00, $3E, $00), {00000000 00000000 00111110 00000000} {26} ($00, $00, $3C, $00), {00000000 00000000 00111100 00000000} {27} ($00, $00, $7C, $00), {00000000 00000000 01111100 00000000} {28} ($00, $01, $F8, $00), {00000000 00000001 11111000 00000000} {29} ($01, $FF, $F0, $00), {00000001 11111111 11110000 00000000} {30} ($03, $FF, $E0, $00), {00000011 11111111 11100000 00000000} {31} ($01, $FF, $80, $00)); {00000001 11111111 10000000 00000000} VAR i : INTEGER; j : INTEGER; Row: pByteArray; begin FOR j := 0 TO Bitmap.Height-1 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO BEGIN Row[i] := G[j,i] END END; Image1.Picture.Graphic := Bitmap end; procedure TForm1.ButtonArrowClick(Sender: TObject); CONST {The "arrow" bitmap was adapted from the LaserJet IIP Printer Tech Ref Manual} Arrow: ARRAY[0..31, 0..3] OF BYTE = { 0} ( ($00, $00, $80, $00), {00000000 00000000 10000000 00000000} { 1} ($00, $00, $C0, $00), {00000000 00000000 11000000 00000000} { 2} ($00, $00, $E0, $00), {00000000 00000000 11100000 00000000} { 3} ($00, $00, $F0, $00), {00000000 00000000 11110000 00000000} { 4} ($00, $00, $F8, $00), {00000000 00000000 11111000 00000000} { 5} ($00, $00, $FC, $00), {00000000 00000000 11111100 00000000} { 6} ($00, $00, $FE, $00), {00000000 00000000 11111110 00000000} { 7} ($00, $00, $FF, $00), {00000000 00000000 11111111 00000000} { 8} ($00, $00, $FF, $80), {00000000 00000000 11111111 10000000} { 9} ($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000} {10} ($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000} {11} ($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000} {12} ($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000} {13} ($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100} {14} ($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110} {15} ($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111} {16} ($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111} {17} ($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110} {18} ($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100} {19} ($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000} {20} ($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000} {21} ($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000} {22} ($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000} {23} ($00, $00, $FF, $80), {00000000 00000000 11111111 10000000} {24} ($00, $00, $FF, $00), {00000000 00000000 11111111 00000000} {25} ($00, $00, $FE, $00), {00000000 00000000 11111110 00000000} {26} ($00, $00, $FC, $00), {00000000 00000000 11111100 00000000} {27} ($00, $00, $F8, $00), {00000000 00000000 11111000 00000000} {28} ($00, $00, $F0, $00), {00000000 00000000 11110000 00000000} {29} ($00, $00, $E0, $00), {00000000 00000000 11100000 00000000} {30} ($00, $00, $C0, $00), {00000000 00000000 11000000 00000000} {31} ($00, $00, $80, $00)); {00000000 00000000 10000000 00000000} VAR i : INTEGER; j : INTEGER; Row: pByteArray; begin FOR j := 0 TO Bitmap.Height-1 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO BEGIN Row[i] := arrow[j,i] END END; Image1.Picture.Graphic := Bitmap end; procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; WITH Bitmap DO BEGIN Width := 32; Height := 32; PixelFormat := pf1bit END; Image1.Picture.Graphic := Bitmap end; procedure TForm1.FormDestroy(Sender: TObject); begin Bitmap.Free end; procedure TForm1.ButtonRandomClick(Sender: TObject); VAR i : INTEGER; j : INTEGER; Row: pByteArray; begin FOR j := 0 TO Bitmap.Height-1 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO BEGIN Row[i] := Random(256) END END; Image1.Picture.Graphic := Bitmap end; procedure TForm1.ButtonInvertClick(Sender: TObject); VAR i : INTEGER; j : INTEGER; Row: pByteArray; begin FOR j := 0 TO Bitmap.Height-1 DO BEGIN Row := pByteArray(Bitmap.Scanline[j]); FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO BEGIN Row[i] := NOT Row[i] END END; Image1.Picture.Graphic := Bitmap end; end.
You can do it like so. In informal testing it appears to take roughly twice as much time as Adobe Photoshop takes to do the same thing, which seems pretty OK to me - there are a lot of things you could do to speed it up.
The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much.
The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.)
One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution.
Anyway, you can do this:
unit GBlur2; interface uses Windows, Graphics; type PRGBTriple = ^TRGBTriple; TRGBTriple = packed record b: byte; //easier to type than rgbtBlue... g: byte; r: byte; end; PRow = ^TRow; TRow = array[0..1000000] of TRGBTriple; PPRows = ^TPRows; TPRows = array[0..1000000] of PRow; const MaxKernelSize = 100; type TKernelSize = 1..MaxKernelSize; TKernel = record Size: TKernelSize; Weights: array[-MaxKernelSize..MaxKernelSize] of single; end; //the idea is that when using a TKernel you ignore the Weights //except for Weights in the range -Size..Size. procedure GBlur(theBitmap: TBitmap; radius: double); implementation uses SysUtils; procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double); //makes K into a gaussian kernel with standard deviation = radius. //for the current application you set MaxData = 255, //DataGranularity = 1. Now the procedure sets the value of //K.Size so that when we use K we will ignore the Weights //that are so small they can't possibly matter. (Small Size //is good because the execution time is going to be //propertional to K.Size.) var j: integer; temp, delta: double; KernelSize: TKernelSize; begin for j:= Low(K.Weights) to High(K.Weights) do begin temp:= j/radius; K.Weights[j]:= exp(- temp*temp/2); end; //now divide by constant so sum(Weights) = 1: temp:= 0; for j:= Low(K.Weights) to High(K.Weights) do temp:= temp + K.Weights[j]; for j:= Low(K.Weights) to High(K.Weights) do K.Weights[j]:= K.Weights[j] / temp; //now discard (or rather mark as ignorable by setting Size) //the entries that are too small to matter - //this is important, otherwise a blur with a small radius //will take as long as with a large radius... KernelSize:= MaxKernelSize; delta:= DataGranularity / (2*MaxData); temp:= 0; while (temp < delta) and (KernelSize > 1) do begin temp:= temp + 2 * K.Weights[KernelSize]; dec(KernelSize); end; K.Size:= KernelSize; //now just to be correct go back and jiggle again so the //sum of the entries we'll be using is exactly 1: temp:= 0; for j:= -K.Size to K.Size do temp:= temp + K.Weights[j]; for j:= -K.Size to K.Size do K.Weights[j]:= K.Weights[j] / temp; end; function TrimInt(Lower, Upper, theInteger: integer): integer; begin if (theInteger <= Upper) and (theInteger >= Lower) then result:= theInteger else if theInteger > Upper then result:= Upper else result:= Lower; end; function TrimReal(Lower, Upper: integer; x: double): integer; begin if (x < upper) and (x >= lower) then result:= trunc(x) else if x > Upper then result:= Upper else result:= Lower; end; procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow); var j, n, LocalRow: integer; tr, tg, tb: double; //tempRed, etc w: double; begin for j:= 0 to High(theRow) do begin tb:= 0; tg:= 0; tr:= 0; for n:= -K.Size to K.Size do begin w:= K.Weights[n]; //the TrimInt keeps us from running off the edge of the row... with theRow[TrimInt(0, High(theRow), j - n)] do begin tb:= tb + w * b; tg:= tg + w * g; tr:= tr + w * r; end; end; with P[j] do begin b:= TrimReal(0, 255, tb); g:= TrimReal(0, 255, tg); r:= TrimReal(0, 255, tr); end; end; Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple)); end; procedure GBlur(theBitmap: TBitmap; radius: double); var Row, Col: integer; theRows: PPRows; K: TKernel; ACol: PRow; P:PRow; begin if (theBitmap.HandleType >< bmDIB) or (theBitmap.PixelFormat >< pf24Bit) then raise exception.Create('GBlur only works for 24-bit bitmaps'); MakeGaussianKernel(K, radius, 255, 1); GetMem(theRows, theBitmap.Height * SizeOf(PRow)); GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple)); //record the location of the bitmap data: for Row:= 0 to theBitmap.Height - 1 do theRows[Row]:= theBitmap.Scanline[Row]; //blur each row: P:= AllocMem(theBitmap.Width*SizeOf(TRGBTriple)); for Row:= 0 to theBitmap.Height - 1 do BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P); //now blur each column ReAllocMem(P, theBitmap.Height*SizeOf(TRGBTriple)); for Col:= 0 to theBitmap.Width - 1 do begin //- first read the column into a TRow: for Row:= 0 to theBitmap.Height - 1 do ACol[Row]:= theRows[Row][Col]; BlurRow(Slice(ACol^, theBitmap.Height), K, P); //now put that row, um, column back into the data: for Row:= 0 to theBitmap.Height - 1 do theRows[Row][Col]:= ACol[Row]; end; FreeMem(theRows); FreeMem(ACol); ReAllocMem(P, 0); end; end.
procedure TForm1.Button1Click(Sender: TObject); var b: TBitmap; begin if not openDialog1.Execute then exit; b:= TBitmap.Create; b.LoadFromFile(OpenDialog1.Filename); b.PixelFormat:= pf24Bit; Canvas.Draw(0, 0, b); GBlur(b, StrToFloat(Edit1.text)); Canvas.Draw(b.Width, 0, b); b.Free; end;
Please email me and tell me if you liked this page.