WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DIB.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DIB;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
		8	Windows, SysUtils, Classes, Graphics, Controls;
		9
		10	type
		11	TRGBQuads = array[0..255] of TRGBQuad;
		12
		13	TPaletteEntries = array[0..255] of TPaletteEntry;
		14
		15	PBGR = ^TBGR;
		16	TBGR = packed record
		17	B, G, R: Byte;
		18	end;
		19
		20	PArrayBGR = ^TArrayBGR;
		21	TArrayBGR = array[0..10000] of TBGR;
		22
		23	PArrayByte = ^TArrayByte;
		24	TArrayByte = array[0..10000] of Byte;
		25
		26	PArrayWord = ^TArrayWord;
		27	TArrayWord = array[0..10000] of Word;
		28
		29	PArrayDWord = ^TArrayDWord;
		30	TArrayDWord = array[0..10000] of DWord;
		31
		32	{ TDIB }
		33
		34	TDIBPixelFormat = record
		35	RBitMask, GBitMask, BBitMask: DWORD;
		36	RBitCount, GBitCount, BBitCount: DWORD;
		37	RShift, GShift, BShift: DWORD;
		38	RBitCount2, GBitCount2, BBitCount2: DWORD;
		39	end;
		40
		41	TDIBSharedImage = class(TSharedImage)
		42	private
		43	FBitCount: Integer;
		44	FBitmapInfo: PBitmapInfo;
		45	FBitmapInfoSize: Integer;
		46	FChangePalette: Boolean;
		47	FColorTable: TRGBQuads;
		48	FColorTablePos: Integer;
		49	FCompressed: Boolean;
		50	FDC: THandle;
		51	FHandle: THandle;
		52	FHeight: Integer;
		53	FMemoryImage: Boolean;
		54	FNextLine: Integer;
		55	FOldHandle: THandle;
		56	FPalette: HPalette;
		57	FPaletteCount: Integer;
		58	FPBits: Pointer;
		59	FPixelFormat: TDIBPixelFormat;
		60	FSize: Integer;
		61	FTopPBits: Pointer;
		62	FWidth: Integer;
		63	FWidthBytes: Integer;
		64	constructor Create;
		65	procedure NewImage(AWidth, AHeight, ABitCount: Integer;
		66	const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
		67	procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
		68	procedure Compress(Source: TDIBSharedImage);
		69	procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
		70	procedure ReadData(Stream: TStream; MemoryImage: Boolean);
		71	function GetPalette: THandle;
		72	procedure SetColorTable(const Value: TRGBQuads);
		73	protected
		74	procedure FreeHandle; override;
		75	public
		76	destructor Destroy; override;
		77	end;
		78
		79	TDIB = class(TGraphic)
		80	private
		81	FCanvas: TCanvas;
		82	FImage: TDIBSharedImage;
		83
		84	FProgressName: string;
		85	FProgressOldY: DWORD;
		86	FProgressOldTime: DWORD;
		87	FProgressOld: DWORD;
		88	FProgressY: DWORD;
		89	{ For speed-up }
		90	FBitCount: Integer;
		91	FHeight: Integer;
		92	FNextLine: Integer;
		93	FNowPixelFormat: TDIBPixelFormat;
		94	FPBits: Pointer;
		95	FSize: Integer;
		96	FTopPBits: Pointer;
		97	FWidth: Integer;
		98	FWidthBytes: Integer;
		99	procedure AllocHandle;
		100	procedure CanvasChanging(Sender: TObject);
		101	procedure Changing(MemoryImage: Boolean);
		102	procedure ConvertBitCount(ABitCount: Integer);
		103	function GetBitmapInfo: PBitmapInfo;
		104	function GetBitmapInfoSize: Integer;
		105	function GetCanvas: TCanvas;
		106	function GetHandle: THandle;
		107	function GetPaletteCount: Integer;
		108	function GetPixel(X, Y: Integer): DWORD;
		109	function GetPBits: Pointer;
		110	function GetPBitsReadOnly: Pointer;
		111	function GetScanLine(Y: Integer): Pointer;
		112	function GetScanLineReadOnly(Y: Integer): Pointer;
		113	function GetTopPBits: Pointer;
		114	function GetTopPBitsReadOnly: Pointer;
		115	procedure SetBitCount(Value: Integer);
		116	procedure SetImage(Value: TDIBSharedImage);
		117	procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
		118	procedure SetPixel(X, Y: Integer; Value: DWORD);
		119	procedure StartProgress(const Name: string);
		120	procedure EndProgress;
		121	procedure UpdateProgress(PercentY: Integer);
		122	protected
		123	procedure DefineProperties(Filer: TFiler); override;
		124	procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
		125	function GetEmpty: Boolean; override;
		126	function GetHeight: Integer; override;
		127	function GetPalette: HPalette; override;
		128	function GetWidth: Integer; override;
		129	procedure ReadData(Stream: TStream); override;
		130	procedure SetHeight(Value: Integer); override;
		131	procedure SetPalette(Value: HPalette); override;
		132	procedure SetWidth(Value: Integer); override;
		133	procedure WriteData(Stream: TStream); override;
		134	public
		135	ColorTable: TRGBQuads;
		136	PixelFormat: TDIBPixelFormat;
		137	constructor Create; override;
		138	destructor Destroy; override;
		139	procedure Assign(Source: TPersistent); override;
		140	procedure Clear;
		141	procedure Compress;
		142	procedure Decompress;
		143	procedure FreeHandle;
		144	procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
		145	APalette: HPALETTE); override;
		146	procedure LoadFromStream(Stream: TStream); override;
		147	procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
		148	var APalette: HPALETTE); override;
		149	procedure SaveToStream(Stream: TStream); override;
		150	procedure SetSize(AWidth, AHeight, ABitCount: Integer);
		151	procedure UpdatePalette;
		152	{ Special effect }
		153	procedure Blur(ABitCount: Integer; Radius: Integer);
		154	procedure Greyscale(ABitCount: Integer);
		155	procedure Mirror(MirrorX, MirrorY: Boolean);
		156	procedure Negative;
		157
		158	property BitCount: Integer read FBitCount write SetBitCount;
		159	property BitmapInfo: PBitmapInfo read GetBitmapInfo;
		160	property BitmapInfoSize: Integer read GetBitmapInfoSize;
		161	property Canvas: TCanvas read GetCanvas;
		162	property Handle: THandle read GetHandle;
		163	property Height: Integer read FHeight write SetHeight;
		164	property NextLine: Integer read FNextLine;
		165	property NowPixelFormat: TDIBPixelFormat read FNowPixelFormat write SetNowPixelFormat;
		166	property PaletteCount: Integer read GetPaletteCount;
		167	property PBits: Pointer read GetPBits;
		168	property PBitsReadOnly: Pointer read GetPBitsReadOnly;
		169	property Pixels[X, Y: Integer]: DWORD read GetPixel write SetPixel;
		170	property ScanLine[Y: Integer]: Pointer read GetScanLine;
		171	property ScanLineReadOnly[Y: Integer]: Pointer read GetScanLineReadOnly;
		172	property Size: Integer read FSize;
		173	property TopPBits: Pointer read GetTopPBits;
		174	property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
		175	property Width: Integer read FWidth write SetWidth;
		176	property WidthBytes: Integer read FWidthBytes;
		177	end;
		178
		179	TDIBitmap = class(TDIB) end;
		180
		181	{ TCustomDXDIB }
		182
		183	TCustomDXDIB = class(TComponent)
		184	private
		185	FDIB: TDIB;
		186	procedure SetDIB(Value: TDIB);
		187	public
		188	constructor Create(AOnwer: TComponent); override;
		189	destructor Destroy; override;
		190	property DIB: TDIB read FDIB write SetDIB;
		191	end;
		192
		193	{ TDXDIB }
		194
		195	TDXDIB = class(TCustomDXDIB)
		196	published
		197	property DIB;
		198	end;
		199
		200	{ TCustomDXPaintBox }
		201
		202	TCustomDXPaintBox = class(TGraphicControl)
		203	private
		204	FAutoStretch: Boolean;
		205	FCenter: Boolean;
		206	FDIB: TDIB;
		207	FKeepAspect: Boolean;
		208	FStretch: Boolean;
		209	FViewWidth: Integer;
		210	FViewHeight: Integer;
		211	procedure SetAutoStretch(Value: Boolean);
		212	procedure SetCenter(Value: Boolean);
		213	procedure SetDIB(Value: TDIB);
		214	procedure SetKeepAspect(Value: Boolean);
		215	procedure SetStretch(Value: Boolean);
		216	procedure SetViewWidth(Value: Integer);
		217	procedure SetViewHeight(Value: Integer);
		218	protected
		219	function GetPalette: HPALETTE; override;
		220	public
		221	constructor Create(AOwner: TComponent); override;
		222	destructor Destroy; override;
		223	procedure Paint; override;
		224	property AutoStretch: Boolean read FAutoStretch write SetAutoStretch;
		225	property Canvas;
		226	property Center: Boolean read FCenter write SetCenter;
		227	property DIB: TDIB read FDIB write SetDIB;
		228	property KeepAspect: Boolean read FKeepAspect write SetKeepAspect;
		229	property Stretch: Boolean read FStretch write SetStretch;
		230	property ViewWidth: Integer read FViewWidth write SetViewWidth;
		231	property ViewHeight: Integer read FViewHeight write SetViewHeight;
		232	end;
		233
		234	{ TDXPaintBox }
		235
		236	TDXPaintBox = class(TCustomDXPaintBox)
		237	published
		238	{$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
		239	property AutoStretch;
		240	property Center;
		241	{$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
		242	property DIB;
		243	property KeepAspect;
		244	property Stretch;
		245	property ViewWidth;
		246	property ViewHeight;
		247
		248	property Align;
		249	property DragCursor;
		250	property DragMode;
		251	property Enabled;
		252	property ParentShowHint;
		253	property PopupMenu;
		254	property ShowHint;
		255	property Visible;
		256	property OnClick;
		257	property OnDblClick;
		258	property OnDragDrop;
		259	property OnDragOver;
		260	property OnEndDrag;
		261	property OnMouseDown;
		262	property OnMouseMove;
		263	property OnMouseUp;
		264	property OnStartDrag;
		265	end;
		266
		267	function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
		268	function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
		269	function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
		270	procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
		271	function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		272	function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		273	function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		274
		275	function GreyscaleColorTable: TRGBQuads;
		276
		277	function RGBQuad(R, G, B: Byte): TRGBQuad;
		278	function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
		279	function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
		280	function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
		281	function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
		282
		283	implementation
		284
		285	uses DXConsts;
		286
		287	function Max(B1, B2: Integer): Integer;
		288	begin
		289	if B1>=B2 then Result := B1 else Result := B2;
		290	end;
		291
		292	function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
		293	begin
		294	Result.RBitMask := ((1 shl RBitCount)-1) shl (GBitCount+BBitCount);
		295	Result.GBitMask := ((1 shl GBitCount)-1) shl (BBitCount);
		296	Result.BBitMask := (1 shl BBitCount)-1;
		297	Result.RBitCount := RBitCount;
		298	Result.GBitCount := GBitCount;
		299	Result.BBitCount := BBitCount;
		300	Result.RBitCount2 := 8-RBitCount;
		301	Result.GBitCount2 := 8-GBitCount;
		302	Result.BBitCount2 := 8-BBitCount;
		303	Result.RShift := (GBitCount+BBitCount)-(8-RBitCount);
		304	Result.GShift := BBitCount-(8-GBitCount);
		305	Result.BShift := 8-BBitCount;
		306	end;
		307
		308	function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
		309
		310	function GetBitCount(b: Integer): Integer;
		311	var
		312	i: Integer;
		313	begin
		314	i := 0;
		315	while (i<31) and (((1 shl i) and b)=0) do Inc(i);
		316
		317	Result := 0;
		318	while ((1 shl i) and b)<>0 do
		319	begin
		320	Inc(i);
		321	Inc(Result);
		322	end;
		323	end;
		324
		325	begin
		326	Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
		327	GetBitCount(BBitMask));
		328	end;
		329
		330	function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
		331	begin
		332	with PixelFormat do
		333	Result := ((R shl RShift) and RBitMask) or ((G shl GShift) and GBitMask) or
		334	((B shr BShift) and BBitMask);
		335	end;
		336
		337	procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
		338	begin
		339	with PixelFormat do
		340	begin
		341	R := (Color and RBitMask) shr RShift;
		342	R := R or (R shr RBitCount2);
		343	G := (Color and GBitMask) shr GShift;
		344	G := G or (G shr GBitCount2);
		345	B := (Color and BBitMask) shl BShift;
		346	B := B or (B shr BBitCount2);
		347	end;
		348	end;
		349
		350	function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		351	begin
		352	with PixelFormat do
		353	begin
		354	Result := (Color and RBitMask) shr RShift;
		355	Result := Result or (Result shr RBitCount);
		356	end;
		357	end;
		358
		359	function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		360	begin
		361	with PixelFormat do
		362	begin
		363	Result := (Color and GBitMask) shr GShift;
		364	Result := Result or (Result shr GBitCount);
		365	end;
		366	end;
		367
		368	function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		369	begin
		370	with PixelFormat do
		371	begin
		372	Result := (Color and BBitMask) shl BShift;
		373	Result := Result or (Result shr BBitCount);
		374	end;
		375	end;
		376
		377	function GreyscaleColorTable: TRGBQuads;
		378	var
		379	i: Integer;
		380	begin
		381	for i:=0 to 255 do
		382	with Result[i] do
		383	begin
		384	rgbRed := i;
		385	rgbGreen := i;
		386	rgbBlue := i;
		387	rgbReserved := 0;
		388	end;
		389	end;
		390
		391	function RGBQuad(R, G, B: Byte): TRGBQuad;
		392	begin
		393	with Result do
		394	begin
		395	rgbRed := R;
		396	rgbGreen := G;
		397	rgbBlue := B;
		398	rgbReserved := 0;
		399	end;
		400	end;
		401
		402	function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
		403	begin
		404	with Result do
		405	with Entry do
		406	begin
		407	rgbRed := peRed;
		408	rgbGreen := peGreen;
		409	rgbBlue := peBlue;
		410	rgbReserved := 0;
		411	end;
		412	end;
		413
		414	function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
		415	var
		416	i: Integer;
		417	begin
		418	for i:=0 to 255 do
		419	Result[i] := PaletteEntryToRGBQuad(Entries[i]);
		420	end;
		421
		422	function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
		423	begin
		424	with Result do
		425	with RGBQuad do
		426	begin
		427	peRed := rgbRed;
		428	peGreen := rgbGreen;
		429	peBlue := rgbBlue;
		430	peFlags := 0;
		431	end;
		432	end;
		433
		434	function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
		435	var
		436	i: Integer;
		437	begin
		438	for i:=0 to 255 do
		439	Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]);
		440	end;
		441
		442	{ TDIBSharedImage }
		443
		444	type
		445	PLocalDIBPixelFormat = ^TLocalDIBPixelFormat;
		446	TLocalDIBPixelFormat = packed record
		447	RBitMask, GBitMask, BBitMask: DWORD;
		448	end;
		449
		450	TPaletteItem = class(TCollectionItem)
		451	private
		452	ID: Integer;
		453	Palette: HPalette;
		454	RefCount: Integer;
		455	ColorTable: TRGBQuads;
		456	ColorTableCount: Integer;
		457	destructor Destroy; override;
		458	procedure AddRef;
		459	procedure Release;
		460	end;
		461
		462	TPaletteManager = class
		463	private
		464	FList: TCollection;
		465	constructor Create;
		466	destructor Destroy; override;
		467	function CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
		468	procedure DeletePalette(var Palette: HPalette);
		469	end;
		470
		471	destructor TPaletteItem.Destroy;
		472	begin
		473	DeleteObject(Palette);
		474	inherited Destroy;
		475	end;
		476
		477	procedure TPaletteItem.AddRef;
		478	begin
		479	Inc(RefCount);
		480	end;
		481
		482	procedure TPaletteItem.Release;
		483	begin
		484	Dec(RefCount);
		485	if RefCount<=0 then Free;
		486	end;
		487
		488	constructor TPaletteManager.Create;
		489	begin
		490	inherited Create;
		491	FList := TCollection.Create(TPaletteItem);
		492	end;
		493
		494	destructor TPaletteManager.Destroy;
		495	begin
		496	FList.Free;
		497	inherited Destroy;
		498	end;
		499
		500	function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
		501	type
		502	TMyLogPalette = record
		503	palVersion: Word;
		504	palNumEntries: Word;
		505	palPalEntry: TPaletteEntries;
		506	end;
		507	var
		508	i, ID: Integer;
		509	Item: TPaletteItem;
		510	LogPalette: TMyLogPalette;
		511	begin
		512	{ Hash key making }
		513	ID := ColorTableCount;
		514	for i:=0 to ColorTableCount-1 do
		515	with ColorTable[i] do
		516	begin
		517	Inc(ID, rgbRed);
		518	Inc(ID, rgbGreen);
		519	Inc(ID, rgbBlue);
		520	end;
		521
		522	{ Does the same palette already exist? }
		523	for i:=0 to FList.Count-1 do
		524	begin
		525	Item := TPaletteItem(FList.Items[i]);
		526	if (Item.ID=ID) and (Item.ColorTableCount=ColorTableCount) and
		527	CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount*SizeOf(TRGBQuad)) then
		528	begin
		529	Item.AddRef; Result := Item.Palette;
		530	Exit;
		531	end;
		532	end;
		533
		534	{ New palette making }
		535	Item := TPaletteItem.Create(FList);
		536	Item.ID := ID;
		537	Move(ColorTable, Item.ColorTable, ColorTableCount*SizeOf(TRGBQuad));
		538	Item.ColorTableCount := ColorTableCount;
		539
		540	with LogPalette do
		541	begin
		542	palVersion := $300;
		543	palNumEntries := ColorTableCount;
		544	palPalEntry := RGBQuadsToPaletteEntries(ColorTable);
		545	end;
		546
		547	Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^);
		548	Item.AddRef; Result := Item.Palette;
		549	end;
		550
		551	procedure TPaletteManager.DeletePalette(var Palette: HPalette);
		552	var
		553	i: Integer;
		554	Item: TPaletteItem;
		555	begin
		556	if Palette=0 then Exit;
		557
		558	for i:=0 to FList.Count-1 do
		559	begin
		560	Item := TPaletteItem(FList.Items[i]);
		561	if (Item.Palette=Palette) then
		562	begin
		563	Palette := 0;
		564	Item.Release;
		565	Exit;
		566	end;
		567	end;
		568	end;
		569
		570	var
		571	FPaletteManager: TPaletteManager;
		572
		573	function PaletteManager: TPaletteManager;
		574	begin
		575	if FPaletteManager=nil then
		576	FPaletteManager := TPaletteManager.Create;
		577	Result := FPaletteManager;
		578	end;
		579
		580	constructor TDIBSharedImage.Create;
		581	begin
		582	inherited Create;
		583	FMemoryImage := True;
		584	SetColorTable(GreyscaleColorTable);
		585	FColorTable := GreyscaleColorTable;
		586	FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
		587	end;
		588
		589	procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer;
		590	const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
		591	var
		592	InfoOfs: Integer;
		593	UsePixelFormat: Boolean;
		594	begin
		595	Create;
		596
		597	{ Pixel format check }
		598	case ABitCount of
		599	1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
		600	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		601	4 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
		602	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		603	8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
		604	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		605	16: begin
		606	if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or
		607	((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then
		608	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		609	end;
		610	24: begin
		611	if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
		612	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		613	end;
		614	32: begin
		615	if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
		616	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		617	end;
		618	else
		619	raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
		620	end;
		621
		622	FBitCount := ABitCount;
		623	FHeight := AHeight;
		624	FWidth := AWidth;
		625	FWidthBytes := (((AWidthABitCount)+31) shr 5) 4;
		626	FNextLine := -FWidthBytes;
		627	FSize := FWidthBytes*FHeight;
		628	UsePixelFormat := ABitCount in [16, 32];
		629
		630	FPixelFormat := PixelFormat;
		631
		632	FPaletteCount := 0;
		633	if FBitCount<=8 then
		634	FPaletteCount := 1 shl FBitCount;
		635
		636	FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
		637	if UsePixelFormat then
		638	Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
		639	Inc(FBitmapInfoSize, SizeOf(TRGBQuad)*FPaletteCount);
		640
		641	GetMem(FBitmapInfo, FBitmapInfoSize);
		642	FillChar(FBitmapInfo^, FBitmapInfoSize, 0);
		643
		644	{ BitmapInfo setting. }
		645	with FBitmapInfo^.bmiHeader do
		646	begin
		647	biSize := SizeOf(TBitmapInfoHeader);
		648	biWidth := FWidth;
		649	biHeight := FHeight;
		650	biPlanes := 1;
		651	biBitCount := FBitCount;
		652	if UsePixelFormat then
		653	biCompression := BI_BITFIELDS
		654	else
		655	begin
		656	if (FBitCount=4) and (Compressed) then
		657	biCompression := BI_RLE4
		658	else if (FBitCount=8) and (Compressed) then
		659	biCompression := BI_RLE8
		660	else
		661	biCompression := BI_RGB;
		662	end;
		663	biSizeImage := FSize;
		664	biXPelsPerMeter := 0;
		665	biYPelsPerMeter := 0;
		666	biClrUsed := 0;
		667	biClrImportant := 0;
		668	end;
		669	InfoOfs := SizeOf(TBitmapInfoHeader);
		670
		671	if UsePixelFormat then
		672	begin
		673	with PLocalDIBPixelFormat(Integer(FBitmapInfo)+InfoOfs)^ do
		674	begin
		675	RBitMask := PixelFormat.RBitMask;
		676	GBitMask := PixelFormat.GBitMask;
		677	BBitMask := PixelFormat.BBitMask;
		678	end;
		679
		680	Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
		681	end;
		682
		683	FColorTablePos := InfoOfs;
		684
		685	FColorTable := ColorTable;
		686	Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
		687
		688	FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
		689	FMemoryImage := MemoryImage or FCompressed;
		690
		691	{ DIB making. }
		692	if not Compressed then
		693	begin
		694	if MemoryImage then
		695	begin
		696	FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
		697	if FPBits=nil then
		698	OutOfMemoryError;
		699	end else
		700	begin
		701	FDC := CreateCompatibleDC(0);
		702
		703	FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
		704	if FHandle=0 then
		705	raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);
		706
		707	FOldHandle := SelectObject(FDC, FHandle);
		708	end;
		709	end;
		710
		711	FTopPBits := Pointer(Integer(FPBits)+(FHeight-1)*FWidthBytes);
		712	end;
		713
		714	procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
		715	begin
		716	if Source.FSize=0 then
		717	begin
		718	Create;
		719	FMemoryImage := MemoryImage;
		720	end else
		721	begin
		722	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		723	Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
		724	if FCompressed then
		725	begin
		726	FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
		727	GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
		728	Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
		729	end else
		730	begin
		731	Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
		732	end;
		733	end;
		734	end;
		735
		736	procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);
		737
		738	procedure EncodeRLE4;
		739	var
		740	Size: Integer;
		741
		742	function AllocByte: PByte;
		743	begin
		744	if Size mod 4096=0 then
		745	ReAllocMem(FPBits, Size+4095);
		746	Result := Pointer(Integer(FPBits)+Size);
		747	Inc(Size);
		748	end;
		749
		750	var
		751	B1, B2, C: Byte;
		752	PB1, PB2: Integer;
		753	Src: PByte;
		754	X, Y: Integer;
		755
		756	function GetPixel(x: Integer): Integer;
		757	begin
		758	if X and 1=0 then
		759	Result := PArrayByte(Src)[X shr 1] shr 4
		760	else
		761	Result := PArrayByte(Src)[X shr 1] and $0F;
		762	end;
		763
		764	begin
		765	Size := 0;
		766
		767	for y:=0 to Source.FHeight-1 do
		768	begin
		769	x := 0;
		770	Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
		771	while x<Source.FWidth do
		772	begin
		773	if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) then
		774	begin
		775	{ Encoding mode }
		776	B1 := 2;
		777	B2 := (GetPixel(x) shl 4) or GetPixel(x+1);
		778
		779	Inc(x, 2);
		780
		781	C := B2;
		782
		783	while (x<Source.FWidth) and (C and $F=GetPixel(x)) and (B1<255) do
		784	begin
		785	Inc(B1);
		786	Inc(x);
		787	C := (C shr 4) or (C shl 4);
		788	end;
		789
		790	AllocByte^ := B1;
		791	AllocByte^ := B2;
		792	end else
		793	if (Source.FWidth-x>5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and
		794	((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then
		795	begin
		796	{ Encoding mode }
		797	AllocByte^ := 2;
		798	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
		799	Inc(x, 2);
		800	end else
		801	begin
		802	if (Source.FWidth-x<4) then
		803	begin
		804	{ Encoding mode }
		805	while Source.FWidth-x>=2 do
		806	begin
		807	AllocByte^ := 2;
		808	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
		809	Inc(x, 2);
		810	end;
		811
		812	if Source.FWidth-x=1 then
		813	begin
		814	AllocByte^ := 1;
		815	AllocByte^ := GetPixel(x) shl 4;
		816	Inc(x);
		817	end;
		818	end else
		819	begin
		820	{ Absolute mode }
		821	PB1 := Size; AllocByte;
		822	PB2 := Size; AllocByte;
		823
		824	B1 := 0;
		825	B2 := 4;
		826
		827	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
		828	AllocByte^ := (GetPixel(x+2) shl 4) or GetPixel(x+3);
		829
		830	Inc(x, 4);
		831
		832	while (x+1<Source.FWidth) and (B2<254) do
		833	begin
		834	if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) and (GetPixel(x+1)=GetPixel(x+3)) then
		835	Break;
		836
		837	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
		838	Inc(B2, 2);
		839	Inc(x, 2);
		840	end;
		841
		842	PByte(Integer(FPBits)+PB1)^ := B1;
		843	PByte(Integer(FPBits)+PB2)^ := B2;
		844	end;
		845	end;
		846
		847	if Size and 1=1 then AllocByte;
		848	end;
		849
		850	{ End of line }
		851	AllocByte^ := 0;
		852	AllocByte^ := 0;
		853	end;
		854
		855	{ End of bitmap }
		856	AllocByte^ := 0;
		857	AllocByte^ := 1;
		858
		859	FBitmapInfo.bmiHeader.biSizeImage := Size;
		860	FSize := Size;
		861	end;
		862
		863	procedure EncodeRLE8;
		864	var
		865	Size: Integer;
		866
		867	function AllocByte: PByte;
		868	begin
		869	if Size mod 4096=0 then
		870	ReAllocMem(FPBits, Size+4095);
		871	Result := Pointer(Integer(FPBits)+Size);
		872	Inc(Size);
		873	end;
		874
		875	var
		876	B1, B2: Byte;
		877	PB1, PB2: Integer;
		878	Src: PByte;
		879	X, Y: Integer;
		880	begin
		881	Size := 0;
		882
		883	for y:=0 to Source.FHeight-1 do
		884	begin
		885	x := 0;
		886	Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
		887	while x<Source.FWidth do
		888	begin
		889	if (Source.FWidth-x>2) and (Src^=PByte(Integer(Src)+1)^) then
		890	begin
		891	{ Encoding mode }
		892	B1 := 2;
		893	B2 := Src^;
		894
		895	Inc(x, 2);
		896	Inc(Src, 2);
		897
		898	while (x<Source.FWidth) and (Src^=B2) and (B1<255) do
		899	begin
		900	Inc(B1);
		901	Inc(x);
		902	Inc(Src);
		903	end;
		904
		905	AllocByte^ := B1;
		906	AllocByte^ := B2;
		907	end else
		908	if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
		909	begin
		910	{ Encoding mode }
		911	AllocByte^ := 1;
		912	AllocByte^ := Src^; Inc(Src);
		913	Inc(x);
		914	end else
		915	begin
		916	if (Source.FWidth-x<4) then
		917	begin
		918	{ Encoding mode }
		919	if Source.FWidth-x=2 then
		920	begin
		921	AllocByte^ := 1;
		922	AllocByte^ := Src^; Inc(Src);
		923
		924	AllocByte^ := 1;
		925	AllocByte^ := Src^; Inc(Src);
		926	Inc(x, 2);
		927	end else
		928	begin
		929	AllocByte^ := 1;
		930	AllocByte^ := Src^; Inc(Src);
		931	Inc(x);
		932	end;
		933	end else
		934	begin
		935	{ Absolute mode }
		936	PB1 := Size; AllocByte;
		937	PB2 := Size; AllocByte;
		938
		939	B1 := 0;
		940	B2 := 3;
		941
		942	Inc(x, 3);
		943
		944	AllocByte^ := Src^; Inc(Src);
		945	AllocByte^ := Src^; Inc(Src);
		946	AllocByte^ := Src^; Inc(Src);
		947
		948	while (x<Source.FWidth) and (B2<255) do
		949	begin
		950	if (Source.FWidth-x>3) and (Src^=PByte(Integer(Src)+1)^) and (Src^=PByte(Integer(Src)+2)^) and (Src^=PByte(Integer(Src)+3)^) then
		951	Break;
		952
		953	AllocByte^ := Src^; Inc(Src);
		954	Inc(B2);
		955	Inc(x);
		956	end;
		957
		958	PByte(Integer(FPBits)+PB1)^ := B1;
		959	PByte(Integer(FPBits)+PB2)^ := B2;
		960	end;
		961	end;
		962
		963	if Size and 1=1 then AllocByte;
		964	end;
		965
		966	{ End of line }
		967	AllocByte^ := 0;
		968	AllocByte^ := 0;
		969	end;
		970
		971	{ End of bitmap }
		972	AllocByte^ := 0;
		973	AllocByte^ := 1;
		974
		975	FBitmapInfo.bmiHeader.biSizeImage := Size;
		976	FSize := Size;
		977	end;
		978
		979	begin
		980	if Source.FCompressed then
		981	Duplicate(Source, Source.FMemoryImage)
		982	else begin
		983	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		984	Source.FPixelFormat, Source.FColorTable, True, True);
		985	case FBitmapInfo.bmiHeader.biCompression of
		986	BI_RLE4: EncodeRLE4;
		987	BI_RLE8: EncodeRLE8;
		988	else
		989	Duplicate(Source, Source.FMemoryImage);
		990	end;
		991	end;
		992	end;
		993
		994	procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
		995
		996	procedure DecodeRLE4;
		997	var
		998	B1, B2, C: Byte;
		999	Dest, Src, P: PByte;
		1000	X, Y, i: Integer;
		1001	begin
		1002	Src := Source.FPBits;
		1003	X := 0;
		1004	Y := 0;
		1005
		1006	while True do
		1007	begin
		1008	B1 := Src^; Inc(Src);
		1009	B2 := Src^; Inc(Src);
		1010
		1011	if B1=0 then
		1012	begin
		1013	case B2 of
		1014	0: begin { End of line }
		1015	X := 0;
		1016	Inc(Y);
		1017	end;
		1018	1: Break; { End of bitmap }
		1019	2: begin { Difference of coordinates }
		1020	Inc(X, B1);
		1021	Inc(Y, B2); Inc(Src, 2);
		1022	end;
		1023	else
		1024	{ Absolute mode }
		1025	Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
		1026
		1027	C := 0;
		1028	for i:=0 to B2-1 do
		1029	begin
		1030	if i and 1=0 then
		1031	begin
		1032	C := Src^; Inc(Src);
		1033	end else
		1034	begin
		1035	C := C shl 4;
		1036	end;
		1037
		1038	P := Pointer(Integer(Dest)+X shr 1);
		1039	if X and 1=0 then
		1040	P^ := (P^ and $0F) or (C and $F0)
		1041	else
		1042	P^ := (P^ and $F0) or ((C and $F0) shr 4);
		1043
		1044	Inc(X);
		1045	end;
		1046	end;
		1047	end else
		1048	begin
		1049	{ Encoding mode }
		1050	Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
		1051
		1052	for i:=0 to B1-1 do
		1053	begin
		1054	P := Pointer(Integer(Dest)+X shr 1);
		1055	if X and 1=0 then
		1056	P^ := (P^ and $0F) or (B2 and $F0)
		1057	else
		1058	P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
		1059
		1060	Inc(X);
		1061
		1062	// Swap nibble
		1063	B2 := (B2 shr 4) or (B2 shl 4);
		1064	end;
		1065	end;
		1066
		1067	{ Word arrangement }
		1068	Inc(Src, Longint(Src) and 1);
		1069	end;
		1070	end;
		1071
		1072	procedure DecodeRLE8;
		1073	var
		1074	B1, B2: Byte;
		1075	Dest, Src: PByte;
		1076	X, Y: Integer;
		1077	begin
		1078	Dest := FPBits;
		1079	Src := Source.FPBits;
		1080	X := 0;
		1081	Y := 0;
		1082
		1083	while True do
		1084	begin
		1085	B1 := Src^; Inc(Src);
		1086	B2 := Src^; Inc(Src);
		1087
		1088	if B1=0 then
		1089	begin
		1090	case B2 of
		1091	0: begin { End of line }
		1092	X := 0; Inc(Y);
		1093	Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
		1094	end;
		1095	1: Break; { End of bitmap }
		1096	2: begin { Difference of coordinates }
		1097	Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
		1098	Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
		1099	end;
		1100	else
		1101	{ Absolute mode }
		1102	Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
		1103	end;
		1104	end else
		1105	begin
		1106	{ Encoding mode }
		1107	FillChar(Dest^, B1, B2); Inc(Dest, B1);
		1108	end;
		1109
		1110	{ Word arrangement }
		1111	Inc(Src, Longint(Src) and 1);
		1112	end;
		1113	end;
		1114
		1115	begin
		1116	if not Source.FCompressed then
		1117	Duplicate(Source, MemoryImage)
		1118	else begin
		1119	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		1120	Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
		1121	case Source.FBitmapInfo.bmiHeader.biCompression of
		1122	BI_RLE4: DecodeRLE4;
		1123	BI_RLE8: DecodeRLE8;
		1124	else
		1125	Duplicate(Source, MemoryImage);
		1126	end;
		1127	end;
		1128	end;
		1129
		1130	procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
		1131	var
		1132	BI: TBitmapInfoHeader;
		1133	BC: TBitmapCoreHeader;
		1134	BCRGB: array[0..255] of TRGBTriple;
		1135
		1136	procedure LoadRLE4;
		1137	begin
		1138	FSize := BI.biSizeImage;
		1139	FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
		1140	FBitmapInfo.bmiHeader.biSizeImage := FSize;
		1141	Stream.ReadBuffer(FPBits^, FSize);
		1142	end;
		1143
		1144	procedure LoadRLE8;
		1145	begin
		1146	FSize := BI.biSizeImage;
		1147	FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
		1148	FBitmapInfo.bmiHeader.biSizeImage := FSize;
		1149	Stream.ReadBuffer(FPBits^, FSize);
		1150	end;
		1151
		1152	procedure LoadRGB;
		1153	var
		1154	y: Integer;
		1155	begin
		1156	if BI.biHeight<0 then
		1157	begin
		1158	for y:=0 to Abs(BI.biHeight)-1 do
		1159	Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
		1160	end else
		1161	begin
		1162	Stream.ReadBuffer(FPBits^, FSize);
		1163	end;
		1164	end;
		1165
		1166	var
		1167	i, PalCount: Integer;
		1168	OS2: Boolean;
		1169	Localpf: TLocalDIBPixelFormat;
		1170	AColorTable: TRGBQuads;
		1171	APixelFormat: TDIBPixelFormat;
		1172	begin
		1173	{ Header size reading }
		1174	i := Stream.Read(BI.biSize, 4);
		1175
		1176	if i=0 then
		1177	begin
		1178	Create;
		1179	Exit;
		1180	end;
		1181	if i<>4 then
		1182	raise EInvalidGraphic.Create(SInvalidDIB);
		1183
		1184	{ Kind check of DIB }
		1185	OS2 := False;
		1186
		1187	case BI.biSize of
		1188	SizeOf(TBitmapCoreHeader):
		1189	begin
		1190	{ OS/2 type }
		1191	Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4);
		1192
		1193	with BI do
		1194	begin
		1195	biClrUsed := 0;
		1196	biCompression := BI_RGB;
		1197	biBitCount := BC.bcBitCount;
		1198	biHeight := BC.bcHeight;
		1199	biWidth := BC.bcWidth;
		1200	end;
		1201
		1202	OS2 := True;
		1203	end;
		1204	SizeOf(TBitmapInfoHeader):
		1205	begin
		1206	{ Windows type }
		1207	Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4);
		1208	end;
		1209	else
		1210	raise EInvalidGraphic.Create(SInvalidDIB);
		1211	end;
		1212
		1213	{ Bit mask reading. }
		1214	if BI.biCompression = BI_BITFIELDS then
		1215	begin
		1216	Stream.ReadBuffer(Localpf, SizeOf(Localpf));
		1217	with Localpf do
		1218	APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
		1219	end else
		1220	begin
		1221	if BI.biBitCount=16 then
		1222	APixelFormat := MakeDIBPixelFormat(5, 5, 5)
		1223	else if BI.biBitCount=32 then
		1224	APixelFormat := MakeDIBPixelFormat(8, 8, 8)
		1225	else
		1226	APixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1227	end;
		1228
		1229	{ Palette reading }
		1230	PalCount := BI.biClrUsed;
		1231	if (PalCount=0) and (BI.biBitCount<=8) then
		1232	PalCount := 1 shl BI.biBitCount;
		1233	if PalCount>256 then PalCount := 256;
		1234
		1235	FillChar(AColorTable, SizeOf(AColorTable), 0);
		1236
		1237	if OS2 then
		1238	begin
		1239	{ OS/2 type }
		1240	Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple)*PalCount);
		1241	for i:=0 to PalCount-1 do
		1242	begin
		1243	with BCRGB[i] do
		1244	AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
		1245	end;
		1246	end else
		1247	begin
		1248	{ Windows type }
		1249	Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
		1250	end;
		1251
		1252	{ DIB �쐬 }
		1253	NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
		1254	MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
		1255
		1256	{ Pixel data reading }
		1257	case BI.biCompression of
		1258	BI_RGB : LoadRGB;
		1259	BI_RLE4 : LoadRLE4;
		1260	BI_RLE8 : LoadRLE8;
		1261	BI_BITFIELDS: LoadRGB;
		1262	else
		1263	raise EInvalidGraphic.Create(SInvalidDIB);
		1264	end;
		1265	end;
		1266
		1267	destructor TDIBSharedImage.Destroy;
		1268	begin
		1269	if FHandle<>0 then
		1270	begin
		1271	if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
		1272	DeleteObject(FHandle);
		1273	end else
		1274	begin
		1275	if FPBits<>nil then
		1276	GlobalFreePtr(FPBits);
		1277	end;
		1278
		1279	PaletteManager.DeletePalette(FPalette);
		1280	if FDC<>0 then DeleteDC(FDC);
		1281
		1282	FreeMem(FBitmapInfo);
		1283	inherited Destroy;
		1284	end;
		1285
		1286	procedure TDIBSharedImage.FreeHandle;
		1287	begin
		1288	end;
		1289
		1290	function TDIBSharedImage.GetPalette: THandle;
		1291	begin
		1292	if FPaletteCount>0 then
		1293	begin
		1294	if FChangePalette then
		1295	begin
		1296	FChangePalette := False;
		1297	PaletteManager.DeletePalette(FPalette);
		1298	FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount);
		1299	end;
		1300	Result := FPalette;
		1301	end else
		1302	Result := 0;
		1303	end;
		1304
		1305	procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads);
		1306	begin
		1307	FColorTable := Value;
		1308	FChangePalette := True;
		1309
		1310	if (FSize>0) and (FPaletteCount>0) then
		1311	begin
		1312	SetDIBColorTable(FDC, 0, 256, FColorTable);
		1313	Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
		1314	end;
		1315	end;
		1316
		1317	{ TDIB }
		1318
		1319	var
		1320	FEmptyDIBImage: TDIBSharedImage;
		1321
		1322	function EmptyDIBImage: TDIBSharedImage;
		1323	begin
		1324	if FEmptyDIBImage=nil then
		1325	begin
		1326	FEmptyDIBImage := TDIBSharedImage.Create;
		1327	FEmptyDIBImage.Reference;
		1328	end;
		1329	Result := FEmptyDIBImage;
		1330	end;
		1331
		1332	constructor TDIB.Create;
		1333	begin
		1334	inherited Create;
		1335	SetImage(EmptyDIBImage);
		1336	end;
		1337
		1338	destructor TDIB.Destroy;
		1339	begin
		1340	SetImage(EmptyDIBImage);
		1341	FCanvas.Free;
		1342	inherited Destroy;
		1343	end;
		1344
		1345	procedure TDIB.Assign(Source: TPersistent);
		1346
		1347	procedure AssignBitmap(Source: TBitmap);
		1348	var
		1349	Data: array[0..1023] of Byte;
		1350	BitmapRec: Windows.PBitmap;
		1351	DIBSectionRec: PDIBSection;
		1352	PaletteEntries: TPaletteEntries;
		1353	begin
		1354	GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries);
		1355	ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
		1356	UpdatePalette;
		1357
		1358	case GetObject(Source.Handle, SizeOf(Data), @Data) of
		1359	SizeOf(Windows.TBitmap):
		1360	begin
		1361	BitmapRec := @Data;
		1362	case BitmapRec^.bmBitsPixel of
		1363	16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
		1364	else
		1365	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1366	end;
		1367	SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
		1368	end;
		1369	SizeOf(TDIBSection):
		1370	begin
		1371	DIBSectionRec := @Data;
		1372	if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
		1373	begin
		1374	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1375	end else
		1376	if DIBSectionRec^.dsBm.bmBitsPixel>8 then
		1377	begin
		1378	PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
		1379	DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
		1380	end else
		1381	begin
		1382	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1383	end;
		1384	SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
		1385	DIBSectionRec^.dsBm.bmBitsPixel);
		1386	end;
		1387	else
		1388	Exit;
		1389	end;
		1390
		1391	FillChar(PBits^, Size, 0);
		1392	Canvas.Draw(0, 0, Source);
		1393	end;
		1394
		1395	procedure AssignGraphic(Source: TGraphic);
		1396	begin
		1397	if Source is TBitmap then
		1398	AssignBitmap(TBitmap(Source))
		1399	else
		1400	begin
		1401	SetSize(Source.Width, Source.Height, 24);
		1402	FillChar(PBits^, Size, 0);
		1403	Canvas.Draw(0, 0, Source);
		1404	end;
		1405	end;
		1406
		1407	begin
		1408	if Source=nil then
		1409	begin
		1410	Clear;
		1411	end else if Source is TDIB then
		1412	begin
		1413	if Source<>Self then
		1414	SetImage(TDIB(Source).FImage);
		1415	end else if Source is TGraphic then
		1416	begin
		1417	AssignGraphic(TGraphic(Source));
		1418	end else if Source is TPicture then
		1419	begin
		1420	if TPicture(Source).Graphic<>nil then
		1421	AssignGraphic(TPicture(Source).Graphic)
		1422	else
		1423	Clear;
		1424	end else
		1425	inherited Assign(Source);
		1426	end;
		1427
		1428	procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
		1429	var
		1430	OldPalette: HPalette;
		1431	OldMode: Integer;
		1432	begin
		1433	if Size>0 then
		1434	begin
		1435	if PaletteCount>0 then
		1436	begin
		1437	OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
		1438	RealizePalette(ACanvas.Handle);
		1439	end else
		1440	OldPalette := 0;
		1441	try
		1442	OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
		1443	try
		1444	GdiFlush;
		1445	if FImage.FMemoryImage then
		1446	begin
		1447	with Rect do
		1448	StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
		1449	0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
		1450	end else
		1451	begin
		1452	with Rect do
		1453	StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
		1454	FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
		1455	end;
		1456	finally
		1457	SetStretchBltMode(ACanvas.Handle, OldMode);
		1458	end;
		1459	finally
		1460	SelectPalette(ACanvas.Handle, OldPalette, False);
		1461	end;
		1462	end;
		1463	end;
		1464
		1465	procedure TDIB.Clear;
		1466	begin
		1467	SetImage(EmptyDIBImage);
		1468	end;
		1469
		1470	procedure TDIB.CanvasChanging(Sender: TObject);
		1471	begin
		1472	Changing(False);
		1473	end;
		1474
		1475	procedure TDIB.Changing(MemoryImage: Boolean);
		1476	var
		1477	TempImage: TDIBSharedImage;
		1478	begin
		1479	if (FImage.RefCount>1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
		1480	begin
		1481	TempImage := TDIBSharedImage.Create;
		1482	try
		1483	TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage);
		1484	except
		1485	TempImage.Free;
		1486	raise;
		1487	end;
		1488	SetImage(TempImage);
		1489	end;
		1490	end;
		1491
		1492	procedure TDIB.AllocHandle;
		1493	var
		1494	TempImage: TDIBSharedImage;
		1495	begin
		1496	if FImage.FMemoryImage then
		1497	begin
		1498	TempImage := TDIBSharedImage.Create;
		1499	try
		1500	TempImage.Decompress(FImage, False);
		1501	except
		1502	TempImage.Free;
		1503	raise;
		1504	end;
		1505	SetImage(TempImage);
		1506	end;
		1507	end;
		1508
		1509	procedure TDIB.Compress;
		1510	var
		1511	TempImage: TDIBSharedImage;
		1512	begin
		1513	if (not FImage.FCompressed) and (BitCount in [4, 8]) then
		1514	begin
		1515	TempImage := TDIBSharedImage.Create;
		1516	try
		1517	TempImage.Compress(FImage);
		1518	except
		1519	TempImage.Free;
		1520	raise;
		1521	end;
		1522	SetImage(TempImage);
		1523	end;
		1524	end;
		1525
		1526	procedure TDIB.Decompress;
		1527	var
		1528	TempImage: TDIBSharedImage;
		1529	begin
		1530	if FImage.FCompressed then
		1531	begin
		1532	TempImage := TDIBSharedImage.Create;
		1533	try
		1534	TempImage.Decompress(FImage, FImage.FMemoryImage);
		1535	except
		1536	TempImage.Free;
		1537	raise;
		1538	end;
		1539	SetImage(TempImage);
		1540	end;
		1541	end;
		1542
		1543	procedure TDIB.FreeHandle;
		1544	var
		1545	TempImage: TDIBSharedImage;
		1546	begin
		1547	if not FImage.FMemoryImage then
		1548	begin
		1549	TempImage := TDIBSharedImage.Create;
		1550	try
		1551	TempImage.Duplicate(FImage, True);
		1552	except
		1553	TempImage.Free;
		1554	raise;
		1555	end;
		1556	SetImage(TempImage);
		1557	end;
		1558	end;
		1559
		1560	function TDIB.GetBitmapInfo: PBitmapInfo;
		1561	begin
		1562	Result := FImage.FBitmapInfo;
		1563	end;
		1564
		1565	function TDIB.GetBitmapInfoSize: Integer;
		1566	begin
		1567	Result := FImage.FBitmapInfoSize;
		1568	end;
		1569
		1570	function TDIB.GetCanvas: TCanvas;
		1571	begin
		1572	if (FCanvas=nil) or (FCanvas.Handle=0) then
		1573	begin
		1574	AllocHandle;
		1575
		1576	FCanvas := TCanvas.Create;
		1577	FCanvas.Handle := FImage.FDC;
		1578	FCanvas.OnChanging := CanvasChanging;
		1579	end;
		1580	Result := FCanvas;
		1581	end;
		1582
		1583	function TDIB.GetEmpty: Boolean;
		1584	begin
		1585	Result := Size=0;
		1586	end;
		1587
		1588	function TDIB.GetHandle: THandle;
		1589	begin
		1590	Changing(True);
		1591	Result := FImage.FHandle;
		1592	end;
		1593
		1594	function TDIB.GetHeight: Integer;
		1595	begin
		1596	Result := FHeight;
		1597	end;
		1598
		1599	function TDIB.GetPalette: HPalette;
		1600	begin
		1601	Result := FImage.GetPalette;
		1602	end;
		1603
		1604	function TDIB.GetPaletteCount: Integer;
		1605	begin
		1606	Result := FImage.FPaletteCount;
		1607	end;
		1608
		1609	function TDIB.GetPBits: Pointer;
		1610	begin
		1611	Changing(True);
		1612
		1613	if not FImage.FMemoryImage then
		1614	GDIFlush;
		1615	Result := FPBits;
		1616	end;
		1617
		1618	function TDIB.GetPBitsReadOnly: Pointer;
		1619	begin
		1620	if not FImage.FMemoryImage then
		1621	GDIFlush;
		1622	Result := FPBits;
		1623	end;
		1624
		1625	function TDIB.GetScanLine(Y: Integer): Pointer;
		1626	begin
		1627	Changing(True);
		1628	if (Y<0) or (Y>=FHeight) then
		1629	raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
		1630
		1631	if not FImage.FMemoryImage then
		1632	GDIFlush;
		1633	Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
		1634	end;
		1635
		1636	function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
		1637	begin
		1638	if (Y<0) or (Y>=FHeight) then
		1639	raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
		1640
		1641	if not FImage.FMemoryImage then
		1642	GDIFlush;
		1643	Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
		1644	end;
		1645
		1646	function TDIB.GetTopPBits: Pointer;
		1647	begin
		1648	Changing(True);
		1649
		1650	if not FImage.FMemoryImage then
		1651	GDIFlush;
		1652	Result := FTopPBits;
		1653	end;
		1654
		1655	function TDIB.GetTopPBitsReadOnly: Pointer;
		1656	begin
		1657	if not FImage.FMemoryImage then
		1658	GDIFlush;
		1659	Result := FTopPBits;
		1660	end;
		1661
		1662	function TDIB.GetWidth: Integer;
		1663	begin
		1664	Result := FWidth;
		1665	end;
		1666
		1667	const
		1668	Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01);
		1669	Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF,
		1670	$FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE);
		1671	Mask4: array[0..1] of DWORD = ($F0, $0F);
		1672	Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0);
		1673
		1674	Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0);
		1675	Shift4: array[0..1] of DWORD = (4, 0);
		1676
		1677	function TDIB.GetPixel(X, Y: Integer): DWORD;
		1678	begin
		1679	Decompress;
		1680
		1681	Result := 0;
		1682	if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
		1683	begin
		1684	case FBitCount of
		1685	1 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
		1686	4 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
		1687	8 : Result := PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X];
		1688	16: Result := PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X];
		1689	24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
		1690	Result := R or (G shl 8) or (B shl 16);
		1691	32: Result := PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X];
		1692	end;
		1693	end;
		1694	end;
		1695
		1696	procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
		1697	var
		1698	P: PByte;
		1699	begin
		1700	Changing(True);
		1701
		1702	if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
		1703	begin
		1704	case FBitCount of
		1705	1 : begin
		1706	P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
		1707	P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
		1708	end;
		1709	4 : begin
		1710	P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
		1711	P^ := (P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]);
		1712	end;
		1713	8 : PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
		1714	16: PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
		1715	24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
		1716	begin
		1717	B := Byte(Value shr 16);
		1718	G := Byte(Value shr 8);
		1719	R := Byte(Value);
		1720	end;
		1721	32: PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
		1722	end;
		1723	end;
		1724	end;
		1725
		1726	procedure TDIB.DefineProperties(Filer: TFiler);
		1727	begin
		1728	inherited DefineProperties(Filer);
		1729	{ For interchangeability with an old version. }
		1730	Filer.DefineBinaryProperty('DIB', LoadFromStream, nil, False);
		1731	end;
		1732
		1733	type
		1734	TGlobalMemoryStream = class(TMemoryStream)
		1735	private
		1736	FHandle: THandle;
		1737	public
		1738	constructor Create(AHandle: THandle);
		1739	destructor Destroy; override;
		1740	end;
		1741
		1742	constructor TGlobalMemoryStream.Create(AHandle: THandle);
		1743	begin
		1744	inherited Create;
		1745	FHandle := AHandle;
		1746	SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
		1747	end;
		1748
		1749	destructor TGlobalMemoryStream.Destroy;
		1750	begin
		1751	GlobalUnLock(FHandle);
		1752	SetPointer(nil, 0);
		1753	inherited Destroy;
		1754	end;
		1755
		1756	procedure TDIB.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
		1757	APalette: HPALETTE);
		1758	var
		1759	Stream: TGlobalMemoryStream;
		1760	begin
		1761	Stream := TGlobalMemoryStream.Create(AData);
		1762	try
		1763	ReadData(Stream);
		1764	finally
		1765	Stream.Free;
		1766	end;
		1767	end;
		1768
		1769	const
		1770	BitmapFileType = Ord('B') + Ord('M')*$100;
		1771
		1772	procedure TDIB.LoadFromStream(Stream: TStream);
		1773	var
		1774	BF: TBitmapFileHeader;
		1775	i: Integer;
		1776	begin
		1777	{ File header reading }
		1778	i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
		1779	if i=0 then Exit;
		1780	if i<>SizeOf(TBitmapFileHeader) then
		1781	raise EInvalidGraphic.Create(SInvalidDIB);
		1782
		1783	{ Is the head 'BM'? }
		1784	if BF.bfType<>BitmapFileType then
		1785	raise EInvalidGraphic.Create(SInvalidDIB);
		1786
		1787	ReadData(Stream);
		1788	end;
		1789
		1790	procedure TDIB.ReadData(Stream: TStream);
		1791	var
		1792	TempImage: TDIBSharedImage;
		1793	begin
		1794	TempImage := TDIBSharedImage.Create;
		1795	try
		1796	TempImage.ReadData(Stream, FImage.FMemoryImage);
		1797	except
		1798	TempImage.Free;
		1799	raise;
		1800	end;
		1801	SetImage(TempImage);
		1802	end;
		1803
		1804	procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
		1805	var APalette: HPALETTE);
		1806	var
		1807	P: Pointer;
		1808	Stream: TMemoryStream;
		1809	begin
		1810	AFormat := CF_DIB;
		1811	APalette := 0;
		1812
		1813	Stream := TMemoryStream.Create;
		1814	try
		1815	WriteData(Stream);
		1816
		1817	AData := GlobalAlloc(GHND, Stream.Size);
		1818	if AData=0 then OutOfMemoryError;
		1819
		1820	P := GlobalLock(AData);
		1821	Move(Stream.Memory^, P^, Stream.Size);
		1822	GlobalUnLock(AData);
		1823	finally
		1824	Stream.Free;
		1825	end;
		1826	end;
		1827
		1828	procedure TDIB.SaveToStream(Stream: TStream);
		1829	var
		1830	BF: TBitmapFileHeader;
		1831	begin
		1832	if Empty then Exit;
		1833
		1834	with BF do
		1835	begin
		1836	bfType := BitmapFileType;
		1837	bfOffBits := SizeOf(TBitmapFileHeader)+BitmapInfoSize;
		1838	bfSize := bfOffBits+FImage.FBitmapInfo^.bmiHeader.biSizeImage;
		1839	bfReserved1 := 0;
		1840	bfReserved2 := 0;
		1841	end;
		1842	Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader));
		1843
		1844	WriteData(Stream);
		1845	end;
		1846
		1847	procedure TDIB.WriteData(Stream: TStream);
		1848	begin
		1849	if Empty then Exit;
		1850
		1851	if not FImage.FMemoryImage then
		1852	GDIFlush;
		1853
		1854	Stream.WriteBuffer(FImage.FBitmapInfo^, FImage.FBitmapInfoSize);
		1855	Stream.WriteBuffer(FImage.FPBits^, FImage.FBitmapInfo.bmiHeader.biSizeImage);
		1856	end;
		1857
		1858	procedure TDIB.SetBitCount(Value: Integer);
		1859	begin
		1860	if Value<=0 then
		1861	Clear
		1862	else
		1863	begin
		1864	if Empty then
		1865	begin
		1866	SetSize(Max(Width, 1), Max(Height, 1), Value)
		1867	end else
		1868	begin
		1869	ConvertBitCount(Value);
		1870	end;
		1871	end;
		1872	end;
		1873
		1874	procedure TDIB.SetHeight(Value: Integer);
		1875	begin
		1876	if Value<=0 then
		1877	Clear
		1878	else
		1879	begin
		1880	if Empty then
		1881	SetSize(Max(Width, 1), Value, 8)
		1882	else
		1883	SetSize(Width, Value, BitCount);
		1884	end;
		1885	end;
		1886
		1887	procedure TDIB.SetWidth(Value: Integer);
		1888	begin
		1889	if Value<=0 then
		1890	Clear
		1891	else
		1892	begin
		1893	if Empty then
		1894	SetSize(Value, Max(Height, 1), 8)
		1895	else
		1896	SetSize(Value, Height, BitCount);
		1897	end;
		1898	end;
		1899
		1900	procedure TDIB.SetImage(Value: TDIBSharedImage);
		1901	begin
		1902	if FImage<>Value then
		1903	begin
		1904	if FCanvas<>nil then
		1905	FCanvas.Handle := 0;
		1906
		1907	FImage.Release;
		1908	FImage := Value;
		1909	FImage.Reference;
		1910
		1911	if FCanvas<>nil then
		1912	FCanvas.Handle := FImage.FDC;
		1913
		1914	ColorTable := FImage.FColorTable;
		1915	PixelFormat := FImage.FPixelFormat;
		1916
		1917	FBitCount := FImage.FBitCount;
		1918	FHeight := FImage.FHeight;
		1919	FNextLine := FImage.FNextLine;
		1920	FNowPixelFormat := FImage.FPixelFormat;
		1921	FPBits := FImage.FPBits;
		1922	FSize := FImage.FSize;
		1923	FTopPBits := FImage.FTopPBits;
		1924	FWidth := FImage.FWidth;
		1925	FWidthBytes := FImage.FWidthBytes;
		1926	end;
		1927	end;
		1928
		1929	procedure TDIB.SetNowPixelFormat(const Value: TDIBPixelFormat);
		1930	var
		1931	Temp: TDIB;
		1932	begin
		1933	if CompareMem(@Value, @FImage.FPixelFormat, SizeOf(TDIBPixelFormat)) then exit;
		1934
		1935	PixelFormat := Value;
		1936
		1937	Temp := TDIB.Create;
		1938	try
		1939	Temp.Assign(Self);
		1940	SetSize(Width, Height, BitCount);
		1941	Canvas.Draw(0, 0, Temp);
		1942	finally
		1943	Temp.Free;
		1944	end;
		1945	end;
		1946
		1947	procedure TDIB.SetPalette(Value: HPalette);
		1948	var
		1949	PaletteEntries: TPaletteEntries;
		1950	begin
		1951	GetPaletteEntries(Value, 0, 256, PaletteEntries);
		1952	DeleteObject(Value);
		1953
		1954	ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
		1955	UpdatePalette;
		1956	end;
		1957
		1958	procedure TDIB.SetSize(AWidth, AHeight, ABitCount: Integer);
		1959	var
		1960	TempImage: TDIBSharedImage;
		1961	begin
		1962	if (AWidth=Width) and (AHeight=Height) and (ABitCount=BitCount) and
		1963	(NowPixelFormat.RBitMask=PixelFormat.RBitMask) and
		1964	(NowPixelFormat.GBitMask=PixelFormat.GBitMask) and
		1965	(NowPixelFormat.BBitMask=PixelFormat.BBitMask) then Exit;
		1966
		1967	if (AWidth<=0) or (AHeight<=0) then
		1968	begin
		1969	Clear;
		1970	Exit;
		1971	end;
		1972
		1973	TempImage := TDIBSharedImage.Create;
		1974	try
		1975	TempImage.NewImage(AWidth, AHeight, ABitCount,
		1976	PixelFormat, ColorTable, FImage.FMemoryImage, False);
		1977	except
		1978	TempImage.Free;
		1979	raise;
		1980	end;
		1981	SetImage(TempImage);
		1982
		1983	PaletteModified := True;
		1984	end;
		1985
		1986	procedure TDIB.UpdatePalette;
		1987	var
		1988	Col: TRGBQuads;
		1989	begin
		1990	if CompareMem(@ColorTable, @FImage.FColorTable, SizeOf(ColorTable)) then Exit;
		1991
		1992	Col := ColorTable;
		1993	Changing(True);
		1994	ColorTable := Col;
		1995	FImage.SetColorTable(ColorTable);
		1996
		1997	PaletteModified := True;
		1998	end;
		1999
		2000	procedure TDIB.ConvertBitCount(ABitCount: Integer);
		2001	var
		2002	Temp: TDIB;
		2003
		2004	procedure CreateHalftonePalette(R, G, B: Integer);
		2005	var
		2006	i: Integer;
		2007	begin
		2008	for i:=0 to 255 do
		2009	with ColorTable[i] do
		2010	begin
		2011	rgbRed := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1);
		2012	rgbGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1);
		2013	rgbBlue := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1);
		2014	end;
		2015	end;
		2016
		2017	procedure PaletteToPalette_Inc;
		2018	var
		2019	x, y: Integer;
		2020	i: DWORD;
		2021	SrcP, DestP: Pointer;
		2022	P: PByte;
		2023	begin
		2024	i := 0;
		2025
		2026	for y:=0 to Height-1 do
		2027	begin
		2028	SrcP := Temp.ScanLine[y];
		2029	DestP := ScanLine[y];
		2030
		2031	for x:=0 to Width-1 do
		2032	begin
		2033	case Temp.BitCount of
		2034	1 : begin
		2035	i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
		2036	end;
		2037	4 : begin
		2038	i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
		2039	end;
		2040	8 : begin
		2041	i := PByte(SrcP)^;
		2042	Inc(PByte(SrcP));
		2043	end;
		2044	end;
		2045
		2046	case BitCount of
		2047	1 : begin
		2048	P := @PArrayByte(DestP)[X shr 3];
		2049	P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
		2050	end;
		2051	4 : begin
		2052	P := @PArrayByte(DestP)[X shr 1];
		2053	P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
		2054	end;
		2055	8 : begin
		2056	PByte(DestP)^ := i;
		2057	Inc(PByte(DestP));
		2058	end;
		2059	end;
		2060	end;
		2061	end;
		2062	end;
		2063
		2064	procedure PaletteToRGB_or_RGBToRGB;
		2065	var
		2066	x, y: Integer;
		2067	SrcP, DestP: Pointer;
		2068	cR, cG, cB: Byte;
		2069	begin
		2070	cR := 0;
		2071	cG := 0;
		2072	cB := 0;
		2073
		2074	for y:=0 to Height-1 do
		2075	begin
		2076	SrcP := Temp.ScanLine[y];
		2077	DestP := ScanLine[y];
		2078
		2079	for x:=0 to Width-1 do
		2080	begin
		2081	case Temp.BitCount of
		2082	1 : begin
		2083	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
		2084	begin
		2085	cR := rgbRed;
		2086	cG := rgbGreen;
		2087	cB := rgbBlue;
		2088	end;
		2089	end;
		2090	4 : begin
		2091	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
		2092	begin
		2093	cR := rgbRed;
		2094	cG := rgbGreen;
		2095	cB := rgbBlue;
		2096	end;
		2097	end;
		2098	8 : begin
		2099	with Temp.ColorTable[PByte(SrcP)^] do
		2100	begin
		2101	cR := rgbRed;
		2102	cG := rgbGreen;
		2103	cB := rgbBlue;
		2104	end;
		2105	Inc(PByte(SrcP));
		2106	end;
		2107	16: begin
		2108	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
		2109	Inc(PWord(SrcP));
		2110	end;
		2111	24: begin
		2112	with PBGR(SrcP)^ do
		2113	begin
		2114	cR := R;
		2115	cG := G;
		2116	cB := B;
		2117	end;
		2118
		2119	Inc(PBGR(SrcP));
		2120	end;
		2121	32: begin
		2122	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
		2123	Inc(PDWORD(SrcP));
		2124	end;
		2125	end;
		2126
		2127	case BitCount of
		2128	16: begin
		2129	PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
		2130	Inc(PWord(DestP));
		2131	end;
		2132	24: begin
		2133	with PBGR(DestP)^ do
		2134	begin
		2135	R := cR;
		2136	G := cG;
		2137	B := cB;
		2138	end;
		2139	Inc(PBGR(DestP));
		2140	end;
		2141	32: begin
		2142	PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
		2143	Inc(PDWORD(DestP));
		2144	end;
		2145	end;
		2146	end;
		2147	end;
		2148	end;
		2149
		2150	begin
		2151	if Size=0 then exit;
		2152
		2153	Temp := TDIB.Create;
		2154	try
		2155	Temp.Assign(Self);
		2156	SetSize(Temp.Width, Temp.Height, ABitCount);
		2157
		2158	if FImage=Temp.FImage then Exit;
		2159
		2160	if (Temp.BitCount<=8) and (BitCount<=8) then
		2161	begin
		2162	{ The image is converted from the palette color image into the palette color image. }
		2163	if Temp.BitCount<=BitCount then
		2164	begin
		2165	PaletteToPalette_Inc;
		2166	end else
		2167	begin
		2168	case BitCount of
		2169	1: begin
		2170	ColorTable[0] := RGBQuad(0, 0, 0);
		2171	ColorTable[1] := RGBQuad(255, 255, 255);
		2172	end;
		2173	4: CreateHalftonePalette(1, 2, 1);
		2174	8: CreateHalftonePalette(3, 3, 2);
		2175	end;
		2176	UpdatePalette;
		2177
		2178	Canvas.Draw(0, 0, Temp);
		2179	end;
		2180	end else
		2181	if (Temp.BitCount<=8) and (BitCount>8) then
		2182	begin
		2183	{ The image is converted from the palette color image into the rgb color image. }
		2184	PaletteToRGB_or_RGBToRGB;
		2185	end else
		2186	if (Temp.BitCount>8) and (BitCount<=8) then
		2187	begin
		2188	{ The image is converted from the rgb color image into the palette color image. }
		2189	case BitCount of
		2190	1: begin
		2191	ColorTable[0] := RGBQuad(0, 0, 0);
		2192	ColorTable[1] := RGBQuad(255, 255, 255);
		2193	end;
		2194	4: CreateHalftonePalette(1, 2, 1);
		2195	8: CreateHalftonePalette(3, 3, 2);
		2196	end;
		2197	UpdatePalette;
		2198
		2199	Canvas.Draw(0, 0, Temp);
		2200	end else
		2201	if (Temp.BitCount>8) and (BitCount>8) then
		2202	begin
		2203	{ The image is converted from the rgb color image into the rgb color image. }
		2204	PaletteToRGB_or_RGBToRGB;
		2205	end;
		2206	finally
		2207	Temp.Free;
		2208	end;
		2209	end;
		2210
		2211	{ Special effect }
		2212
		2213	procedure TDIB.StartProgress(const Name: string);
		2214	begin
		2215	FProgressName := Name;
		2216	FProgressOld := 0;
		2217	FProgressOldTime := GetTickCount;
		2218	FProgressY := 0;
		2219	FProgressOldY := 0;
		2220	Progress(Self, psStarting, 0, False, Rect(0, 0, Width, Height), FProgressName);
		2221	end;
		2222
		2223	procedure TDIB.EndProgress;
		2224	begin
		2225	Progress(Self, psEnding, 100, True, Rect(0, FProgressOldY, Width, Height), FProgressName);
		2226	end;
		2227
		2228	procedure TDIB.UpdateProgress(PercentY: Integer);
		2229	var
		2230	Redraw: Boolean;
		2231	Percent: DWORD;
		2232	begin
		2233	Redraw := (GetTickCount-FProgressOldTime>200) and (FProgressY-FProgressOldY>32) and
		2234	(((Height div 3>Integer(FProgressY)) and (FProgressOldY=0)) or (FProgressOldY<>0));
		2235
		2236	Percent := PercentY*100 div Height;
		2237
		2238	if (Percent<>FProgressOld) or (Redraw) then
		2239	begin
		2240	Progress(Self, psRunning, Percent, Redraw,
		2241	Rect(0, FProgressOldY, Width, FProgressY), FProgressName);
		2242	if Redraw then
		2243	begin
		2244	FProgressOldY := FProgressY;
		2245	FProgressOldTime := GetTickCount;
		2246	end;
		2247
		2248	FProgressOld := Percent;
		2249	end;
		2250
		2251	Inc(FProgressY);
		2252	end;
		2253
		2254	procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
		2255	type
		2256	TAve = record
		2257	cR, cG, cB: DWORD;
		2258	c: DWORD;
		2259	end;
		2260	TArrayAve = array[0..0] of TAve;
		2261
		2262	var
		2263	Temp: TDIB;
		2264
		2265	procedure AddAverage(Y, XCount: Integer; var Ave: TArrayAve);
		2266	var
		2267	X: Integer;
		2268	SrcP: Pointer;
		2269	AveP: ^TAve;
		2270	R, G, B: Byte;
		2271	begin
		2272	case Temp.BitCount of
		2273	1 : begin
		2274	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2275	AveP := @Ave;
		2276	for x:=0 to XCount-1 do
		2277	begin
		2278	with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
		2279	begin
		2280	Inc(cR, rgbRed);
		2281	Inc(cG, rgbGreen);
		2282	Inc(cB, rgbBlue);
		2283	Inc(c);
		2284	end;
		2285	Inc(AveP);
		2286	end;
		2287	end;
		2288	4 : begin
		2289	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2290	AveP := @Ave;
		2291	for x:=0 to XCount-1 do
		2292	begin
		2293	with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
		2294	begin
		2295	Inc(cR, rgbRed);
		2296	Inc(cG, rgbGreen);
		2297	Inc(cB, rgbBlue);
		2298	Inc(c);
		2299	end;
		2300	Inc(AveP);
		2301	end;
		2302	end;
		2303	8 : begin
		2304	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2305	AveP := @Ave;
		2306	for x:=0 to XCount-1 do
		2307	begin
		2308	with Temp.ColorTable[PByte(SrcP)^], AveP^ do
		2309	begin
		2310	Inc(cR, rgbRed);
		2311	Inc(cG, rgbGreen);
		2312	Inc(cB, rgbBlue);
		2313	Inc(c);
		2314	end;
		2315	Inc(PByte(SrcP));
		2316	Inc(AveP);
		2317	end;
		2318	end;
		2319	16: begin
		2320	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2321	AveP := @Ave;
		2322	for x:=0 to XCount-1 do
		2323	begin
		2324	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		2325	with AveP^ do
		2326	begin
		2327	Inc(cR, R);
		2328	Inc(cG, G);
		2329	Inc(cB, B);
		2330	Inc(c);
		2331	end;
		2332	Inc(PWord(SrcP));
		2333	Inc(AveP);
		2334	end;
		2335	end;
		2336	24: begin
		2337	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2338	AveP := @Ave;
		2339	for x:=0 to XCount-1 do
		2340	begin
		2341	with PBGR(SrcP)^, AveP^ do
		2342	begin
		2343	Inc(cR, R);
		2344	Inc(cG, G);
		2345	Inc(cB, B);
		2346	Inc(c);
		2347	end;
		2348	Inc(PBGR(SrcP));
		2349	Inc(AveP);
		2350	end;
		2351	end;
		2352	32: begin
		2353	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2354	AveP := @Ave;
		2355	for x:=0 to XCount-1 do
		2356	begin
		2357	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		2358	with AveP^ do
		2359	begin
		2360	Inc(cR, R);
		2361	Inc(cG, G);
		2362	Inc(cB, B);
		2363	Inc(c);
		2364	end;
		2365	Inc(PDWORD(SrcP));
		2366	Inc(AveP);
		2367	end;
		2368	end;
		2369	end;
		2370	end;
		2371
		2372	procedure DeleteAverage(Y, XCount: Integer; var Ave: TArrayAve);
		2373	var
		2374	X: Integer;
		2375	SrcP: Pointer;
		2376	AveP: ^TAve;
		2377	R, G, B: Byte;
		2378	begin
		2379	case Temp.BitCount of
		2380	1 : begin
		2381	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2382	AveP := @Ave;
		2383	for x:=0 to XCount-1 do
		2384	begin
		2385	with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
		2386	begin
		2387	Dec(cR, rgbRed);
		2388	Dec(cG, rgbGreen);
		2389	Dec(cB, rgbBlue);
		2390	Dec(c);
		2391	end;
		2392	Inc(AveP);
		2393	end;
		2394	end;
		2395	4 : begin
		2396	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2397	AveP := @Ave;
		2398	for x:=0 to XCount-1 do
		2399	begin
		2400	with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
		2401	begin
		2402	Dec(cR, rgbRed);
		2403	Dec(cG, rgbGreen);
		2404	Dec(cB, rgbBlue);
		2405	Dec(c);
		2406	end;
		2407	Inc(AveP);
		2408	end;
		2409	end;
		2410	8 : begin
		2411	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2412	AveP := @Ave;
		2413	for x:=0 to XCount-1 do
		2414	begin
		2415	with Temp.ColorTable[PByte(SrcP)^], AveP^ do
		2416	begin
		2417	Dec(cR, rgbRed);
		2418	Dec(cG, rgbGreen);
		2419	Dec(cB, rgbBlue);
		2420	Dec(c);
		2421	end;
		2422	Inc(PByte(SrcP));
		2423	Inc(AveP);
		2424	end;
		2425	end;
		2426	16: begin
		2427	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2428	AveP := @Ave;
		2429	for x:=0 to XCount-1 do
		2430	begin
		2431	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		2432	with AveP^ do
		2433	begin
		2434	Dec(cR, R);
		2435	Dec(cG, G);
		2436	Dec(cB, B);
		2437	Dec(c);
		2438	end;
		2439	Inc(PWord(SrcP));
		2440	Inc(AveP);
		2441	end;
		2442	end;
		2443	24: begin
		2444	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2445	AveP := @Ave;
		2446	for x:=0 to XCount-1 do
		2447	begin
		2448	with PBGR(SrcP)^, AveP^ do
		2449	begin
		2450	Dec(cR, R);
		2451	Dec(cG, G);
		2452	Dec(cB, B);
		2453	Dec(c);
		2454	end;
		2455	Inc(PBGR(SrcP));
		2456	Inc(AveP);
		2457	end;
		2458	end;
		2459	32: begin
		2460	SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
		2461	AveP := @Ave;
		2462	for x:=0 to XCount-1 do
		2463	begin
		2464	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		2465	with AveP^ do
		2466	begin
		2467	Dec(cR, R);
		2468	Dec(cG, G);
		2469	Dec(cB, B);
		2470	Dec(c);
		2471	end;
		2472	Inc(PDWORD(SrcP));
		2473	Inc(AveP);
		2474	end;
		2475	end;
		2476	end;
		2477	end;
		2478
		2479	procedure Blur_Radius_Other;
		2480	var
		2481	FirstX, LastX, FirstX2, LastX2, FirstY, LastY: Integer;
		2482	x, y, x2, y2, jx, jy: Integer;
		2483	Ave: TAve;
		2484	AveX: ^TArrayAve;
		2485	DestP: Pointer;
		2486	P: PByte;
		2487	begin
		2488	GetMem(AveX, Width*SizeOf(TAve));
		2489	try
		2490	FillChar(AveX^, Width*SizeOf(TAve), 0);
		2491
		2492	FirstX2 := -1;
		2493	LastX2 := -1;
		2494	FirstY := -1;
		2495	LastY := -1;
		2496
		2497	x := 0;
		2498	for x2:=-Radius to Radius do
		2499	begin
		2500	jx := x+x2;
		2501	if (jx>=0) and (jx<Width) then
		2502	begin
		2503	if FirstX2=-1 then FirstX2 := jx;
		2504	if LastX2<jx then LastX2 := jx;
		2505	end;
		2506	end;
		2507
		2508	y := 0;
		2509	for y2:=-Radius to Radius do
		2510	begin
		2511	jy := y+y2;
		2512	if (jy>=0) and (jy<Height) then
		2513	begin
		2514	if FirstY=-1 then FirstY := jy;
		2515	if LastY<jy then LastY := jy;
		2516	end;
		2517	end;
		2518
		2519	for y:=FirstY to LastY do
		2520	AddAverage(y, Temp.Width, AveX^);
		2521
		2522	for y:=0 to Height-1 do
		2523	begin
		2524	DestP := ScanLine[y];
		2525
		2526	{ The average is updated. }
		2527	if y-FirstY=Radius+1 then
		2528	begin
		2529	DeleteAverage(FirstY, Temp.Width, AveX^);
		2530	Inc(FirstY);
		2531	end;
		2532
		2533	if LastY-y=Radius-1 then
		2534	begin
		2535	Inc(LastY); if LastY>=Height then LastY := Height-1;
		2536	AddAverage(LastY, Temp.Width, AveX^);
		2537	end;
		2538
		2539	{ The average is calculated again. }
		2540	FirstX := FirstX2;
		2541	LastX := LastX2;
		2542
		2543	FillChar(Ave, SizeOf(Ave), 0);
		2544	for x:=FirstX to LastX do
		2545	with AveX[x] do
		2546	begin
		2547	Inc(Ave.cR, cR);
		2548	Inc(Ave.cG, cG);
		2549	Inc(Ave.cB, cB);
		2550	Inc(Ave.c, c);
		2551	end;
		2552
		2553	for x:=0 to Width-1 do
		2554	begin
		2555	{ The average is updated. }
		2556	if x-FirstX=Radius+1 then
		2557	begin
		2558	with AveX[FirstX] do
		2559	begin
		2560	Dec(Ave.cR, cR);
		2561	Dec(Ave.cG, cG);
		2562	Dec(Ave.cB, cB);
		2563	Dec(Ave.c, c);
		2564	end;
		2565	Inc(FirstX);
		2566	end;
		2567
		2568	if LastX-x=Radius-1 then
		2569	begin
		2570	Inc(LastX); if LastX>=Width then LastX := Width-1;
		2571	with AveX[LastX] do
		2572	begin
		2573	Inc(Ave.cR, cR);
		2574	Inc(Ave.cG, cG);
		2575	Inc(Ave.cB, cB);
		2576	Inc(Ave.c, c);
		2577	end;
		2578	end;
		2579
		2580	{ The average is written. }
		2581	case BitCount of
		2582	1 : begin
		2583	P := @PArrayByte(DestP)[X shr 3];
		2584	with Ave do
		2585	P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR+cG+cB) div c) div 3>127)) shl Shift1[X and 7]);
		2586	end;
		2587	4 : begin
		2588	P := @PArrayByte(DestP)[X shr 1];
		2589	with Ave do
		2590	P^ := (P^ and Mask4n[X and 1]) or (((((cR+cG+cB) div c) div 3) shr 4) shl Shift4[X and 1]);
		2591	end;
		2592	8 : begin
		2593	with Ave do
		2594	PByte(DestP)^ := ((cR+cG+cB) div c) div 3;
		2595	Inc(PByte(DestP));
		2596	end;
		2597	16: begin
		2598	with Ave do
		2599	PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
		2600	Inc(PWORD(DestP));
		2601	end;
		2602	24: begin
		2603	with PBGR(DestP)^, Ave do
		2604	begin
		2605	R := cR div c;
		2606	G := cG div c;
		2607	B := cB div c;
		2608	end;
		2609	Inc(PBGR(DestP));
		2610	end;
		2611	32: begin
		2612	with Ave do
		2613	PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
		2614	Inc(PDWORD(DestP));
		2615	end;
		2616	end;
		2617	end;
		2618
		2619	UpdateProgress(y);
		2620	end;
		2621	finally
		2622	FreeMem(AveX);
		2623	end;
		2624	end;
		2625
		2626	var
		2627	i, j: Integer;
		2628	begin
		2629	if Empty or (Radius=0) then Exit;
		2630
		2631	Radius := Abs(Radius);
		2632
		2633	StartProgress('Blur');
		2634	try
		2635	Temp := TDIB.Create;
		2636	try
		2637	Temp.Assign(Self);
		2638	SetSize(Width, Height, ABitCount);
		2639
		2640	if ABitCount<=8 then
		2641	begin
		2642	FillChar(ColorTable, SizeOf(ColorTable), 0);
		2643	for i:=0 to (1 shl ABitCount)-1 do
		2644	begin
		2645	j := i * (1 shl (8-ABitCount));
		2646	j := j or (j shr ABitCount);
		2647	ColorTable[i] := RGBQuad(j, j, j);
		2648	end;
		2649	UpdatePalette;
		2650	end;
		2651
		2652	Blur_Radius_Other;
		2653	finally
		2654	Temp.Free;
		2655	end;
		2656	finally
		2657	EndProgress;
		2658	end;
		2659	end;
		2660
		2661	procedure TDIB.Greyscale(ABitCount: Integer);
		2662	var
		2663	YTblR, YTblG, YTblB: array[0..255] of Byte;
		2664	i, j, x, y: Integer;
		2665	c: DWORD;
		2666	R, G, B: Byte;
		2667	Temp: TDIB;
		2668	DestP, SrcP: Pointer;
		2669	P: PByte;
		2670	begin
		2671	if Empty then exit;
		2672
		2673	Temp := TDIB.Create;
		2674	try
		2675	Temp.Assign(Self);
		2676	SetSize(Width, Height, ABitCount);
		2677
		2678	if ABitCount<=8 then
		2679	begin
		2680	FillChar(ColorTable, SizeOf(ColorTable), 0);
		2681	for i:=0 to (1 shl ABitCount)-1 do
		2682	begin
		2683	j := i * (1 shl (8-ABitCount));
		2684	j := j or (j shr ABitCount);
		2685	ColorTable[i] := RGBQuad(j, j, j);
		2686	end;
		2687	UpdatePalette;
		2688	end;
		2689
		2690	for i:=0 to 255 do
		2691	begin
		2692	YTblR[i] := Trunc(0.3588*i);
		2693	YTblG[i] := Trunc(0.4020*i);
		2694	YTblB[i] := Trunc(0.2392*i);
		2695	end;
		2696
		2697	c := 0;
		2698
		2699	StartProgress('Greyscale');
		2700	try
		2701	for y:=0 to Height-1 do
		2702	begin
		2703	DestP := ScanLine[y];
		2704	SrcP := Temp.ScanLine[y];
		2705
		2706	for x:=0 to Width-1 do
		2707	begin
		2708	case Temp.BitCount of
		2709	1 : begin
		2710	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
		2711	c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
		2712	end;
		2713	4 : begin
		2714	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
		2715	c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
		2716	end;
		2717	8 : begin
		2718	with Temp.ColorTable[PByte(SrcP)^] do
		2719	c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
		2720	Inc(PByte(SrcP));
		2721	end;
		2722	16: begin
		2723	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		2724	c := YTblR[R]+YTblR[G]+YTblR[B];
		2725	Inc(PWord(SrcP));
		2726	end;
		2727	24: begin
		2728	with PBGR(SrcP)^ do
		2729	c := YTblR[R]+YTblG[G]+YTblB[B];
		2730	Inc(PBGR(SrcP));
		2731	end;
		2732	32: begin
		2733	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		2734	c := YTblR[R]+YTblR[G]+YTblR[B];
		2735	Inc(PDWORD(SrcP));
		2736	end;
		2737	end;
		2738
		2739	case BitCount of
		2740	1 : begin
		2741	P := @PArrayByte(DestP)[X shr 3];
		2742	P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c>127)) shl Shift1[X and 7]);
		2743	end;
		2744	4 : begin
		2745	P := @PArrayByte(DestP)[X shr 1];
		2746	P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
		2747	end;
		2748	8 : begin
		2749	PByte(DestP)^ := c;
		2750	Inc(PByte(DestP));
		2751	end;
		2752	16: begin
		2753	PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
		2754	Inc(PWord(DestP));
		2755	end;
		2756	24: begin
		2757	with PBGR(DestP)^ do
		2758	begin
		2759	R := c;
		2760	G := c;
		2761	B := c;
		2762	end;
		2763	Inc(PBGR(DestP));
		2764	end;
		2765	32: begin
		2766	PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
		2767	Inc(PDWORD(DestP));
		2768	end;
		2769	end;
		2770	end;
		2771
		2772	UpdateProgress(y);
		2773	end;
		2774	finally
		2775	EndProgress;
		2776	end;
		2777	finally
		2778	Temp.Free;
		2779	end;
		2780	end;
		2781
		2782	procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
		2783	var
		2784	x, y, Width2, c: Integer;
		2785	P1, P2, TempBuf: Pointer;
		2786	begin
		2787	if Empty then exit;
		2788	if (not MirrorX) and (not MirrorY) then Exit;
		2789
		2790	if (not MirrorX) and (MirrorY) then
		2791	begin
		2792	GetMem(TempBuf, WidthBytes);
		2793	try
		2794	StartProgress('Mirror');
		2795	try
		2796	for y:=0 to Height shr 1-1 do
		2797	begin
		2798	P1 := ScanLine[y];
		2799	P2 := ScanLine[Height-y-1];
		2800
		2801	Move(P1^, TempBuf^, WidthBytes);
		2802	Move(P2^, P1^, WidthBytes);
		2803	Move(TempBuf^, P2^, WidthBytes);
		2804
		2805	UpdateProgress(y*2);
		2806	end;
		2807	finally
		2808	EndProgress;
		2809	end;
		2810	finally
		2811	FreeMem(TempBuf, WidthBytes);
		2812	end;
		2813	end else if (MirrorX) and (not MirrorY) then
		2814	begin
		2815	Width2 := Width shr 1;
		2816
		2817	StartProgress('Mirror');
		2818	try
		2819	for y:=0 to Height-1 do
		2820	begin
		2821	P1 := ScanLine[y];
		2822
		2823	case BitCount of
		2824	1 : begin
		2825	for x:=0 to Width2-1 do
		2826	begin
		2827	c := Pixels[x, y];
		2828	Pixels[x, y] := Pixels[Width-x-1, y];
		2829	Pixels[Width-x-1, y] := c;
		2830	end;
		2831	end;
		2832	4 : begin
		2833	for x:=0 to Width2-1 do
		2834	begin
		2835	c := Pixels[x, y];
		2836	Pixels[x, y] := Pixels[Width-x-1, y];
		2837	Pixels[Width-x-1, y] := c;
		2838	end;
		2839	end;
		2840	8 : begin
		2841	P2 := Pointer(Integer(P1)+Width-1);
		2842	for x:=0 to Width2-1 do
		2843	begin
		2844	PByte(@c)^ := PByte(P1)^;
		2845	PByte(P1)^ := PByte(P2)^;
		2846	PByte(P2)^ := PByte(@c)^;
		2847	Inc(PByte(P1));
		2848	Dec(PByte(P2));
		2849	end;
		2850	end;
		2851	16: begin
		2852	P2 := Pointer(Integer(P1)+(Width-1)*2);
		2853	for x:=0 to Width2-1 do
		2854	begin
		2855	PWord(@c)^ := PWord(P1)^;
		2856	PWord(P1)^ := PWord(P2)^;
		2857	PWord(P2)^ := PWord(@c)^;
		2858	Inc(PWord(P1));
		2859	Dec(PWord(P2));
		2860	end;
		2861	end;
		2862	24: begin
		2863	P2 := Pointer(Integer(P1)+(Width-1)*3);
		2864	for x:=0 to Width2-1 do
		2865	begin
		2866	PBGR(@c)^ := PBGR(P1)^;
		2867	PBGR(P1)^ := PBGR(P2)^;
		2868	PBGR(P2)^ := PBGR(@c)^;
		2869	Inc(PBGR(P1));
		2870	Dec(PBGR(P2));
		2871	end;
		2872	end;
		2873	32: begin
		2874	P2 := Pointer(Integer(P1)+(Width-1)*4);
		2875	for x:=0 to Width2-1 do
		2876	begin
		2877	PDWORD(@c)^ := PDWORD(P1)^;
		2878	PDWORD(P1)^ := PDWORD(P2)^;
		2879	PDWORD(P2)^ := PDWORD(@c)^;
		2880	Inc(PDWORD(P1));
		2881	Dec(PDWORD(P2));
		2882	end;
		2883	end;
		2884	end;
		2885
		2886	UpdateProgress(y);
		2887	end;
		2888	finally
		2889	EndProgress;
		2890	end;
		2891	end else if (MirrorX) and (MirrorY) then
		2892	begin
		2893	StartProgress('Mirror');
		2894	try
		2895	for y:=0 to Height shr 1-1 do
		2896	begin
		2897	P1 := ScanLine[y];
		2898	P2 := ScanLine[Height-y-1];
		2899
		2900	case BitCount of
		2901	1 : begin
		2902	for x:=0 to Width-1 do
		2903	begin
		2904	c := Pixels[x, y];
		2905	Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
		2906	Pixels[Width-x-1, Height-y-1] := c;
		2907	end;
		2908	end;
		2909	4 : begin
		2910	for x:=0 to Width-1 do
		2911	begin
		2912	c := Pixels[x, y];
		2913	Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
		2914	Pixels[Width-x-1, Height-y-1] := c;
		2915	end;
		2916	end;
		2917	8 : begin
		2918	P2 := Pointer(Integer(P2)+Width-1);
		2919	for x:=0 to Width-1 do
		2920	begin
		2921	PByte(@c)^ := PByte(P1)^;
		2922	PByte(P1)^ := PByte(P2)^;
		2923	PByte(P2)^ := PByte(@c)^;
		2924	Inc(PByte(P1));
		2925	Dec(PByte(P2));
		2926	end;
		2927	end;
		2928	16: begin
		2929	P2 := Pointer(Integer(P2)+(Width-1)*2);
		2930	for x:=0 to Width-1 do
		2931	begin
		2932	PWord(@c)^ := PWord(P1)^;
		2933	PWord(P1)^ := PWord(P2)^;
		2934	PWord(P2)^ := PWord(@c)^;
		2935	Inc(PWord(P1));
		2936	Dec(PWord(P2));
		2937	end;
		2938	end;
		2939	24: begin
		2940	P2 := Pointer(Integer(P2)+(Width-1)*3);
		2941	for x:=0 to Width-1 do
		2942	begin
		2943	PBGR(@c)^ := PBGR(P1)^;
		2944	PBGR(P1)^ := PBGR(P2)^;
		2945	PBGR(P2)^ := PBGR(@c)^;
		2946	Inc(PBGR(P1));
		2947	Dec(PBGR(P2));
		2948	end;
		2949	end;
		2950	32: begin
		2951	P2 := Pointer(Integer(P2)+(Width-1)*4);
		2952	for x:=0 to Width-1 do
		2953	begin
		2954	PDWORD(@c)^ := PDWORD(P1)^;
		2955	PDWORD(P1)^ := PDWORD(P2)^;
		2956	PDWORD(P2)^ := PDWORD(@c)^;
		2957	Inc(PDWORD(P1));
		2958	Dec(PDWORD(P2));
		2959	end;
		2960	end;
		2961	end;
		2962
		2963	UpdateProgress(y*2);
		2964	end;
		2965	finally
		2966	EndProgress;
		2967	end;
		2968	end;
		2969	end;
		2970
		2971	procedure TDIB.Negative;
		2972	var
		2973	i, i2: Integer;
		2974	P: Pointer;
		2975	begin
		2976	if Empty then exit;
		2977
		2978	if BitCount<=8 then
		2979	begin
		2980	for i:=0 to 255 do
		2981	with ColorTable[i] do
		2982	begin
		2983	rgbRed := 255-rgbRed;
		2984	rgbGreen := 255-rgbGreen;
		2985	rgbBlue := 255-rgbBlue;
		2986	end;
		2987	UpdatePalette;
		2988	end else
		2989	begin
		2990	P := PBits;
		2991	i2 := Size;
		2992	asm
		2993	mov ecx,i2
		2994	mov eax,P
		2995	mov edx,ecx
		2996
		2997	{ Unit of DWORD. }
		2998	@@qword_skip:
		2999	shr ecx,2
		3000	jz @@dword_skip
		3001
		3002	dec ecx
		3003	@@dword_loop:
		3004	not dword ptr [eax+ecx*4]
		3005	dec ecx
		3006	jnl @@dword_loop
		3007
		3008	mov ecx,edx
		3009	shr ecx,2
		3010	add eax,ecx*4
		3011
		3012	{ Unit of Byte. }
		3013	@@dword_skip:
		3014	mov ecx,edx
		3015	and ecx,3
		3016	jz @@byte_skip
		3017
		3018	dec ecx
		3019	@@loop_byte:
		3020	not byte ptr [eax+ecx]
		3021	dec ecx
		3022	jnl @@loop_byte
		3023
		3024	@@byte_skip:
		3025	end;
		3026	end;
		3027	end;
		3028
		3029	{ TCustomDXDIB }
		3030
		3031	constructor TCustomDXDIB.Create(AOnwer: TComponent);
		3032	begin
		3033	inherited Create(AOnwer);
		3034	FDIB := TDIB.Create;
		3035	end;
		3036
		3037	destructor TCustomDXDIB.Destroy;
		3038	begin
		3039	FDIB.Free;
		3040	inherited Destroy;
		3041	end;
		3042
		3043	procedure TCustomDXDIB.SetDIB(Value: TDIB);
		3044	begin
		3045	FDIB.Assign(Value);
		3046	end;
		3047
		3048	{ TCustomDXPaintBox }
		3049
		3050	constructor TCustomDXPaintBox.Create(AOwner: TComponent);
		3051	begin
		3052	inherited Create(AOwner);
		3053	FDIB := TDIB.Create;
		3054
		3055	ControlStyle := ControlStyle + [csReplicatable];
		3056	Height := 105;
		3057	Width := 105;
		3058	end;
		3059
		3060	destructor TCustomDXPaintBox.Destroy;
		3061	begin
		3062	FDIB.Free;
		3063	inherited Destroy;
		3064	end;
		3065
		3066	function TCustomDXPaintBox.GetPalette: HPALETTE;
		3067	begin
		3068	Result := FDIB.Palette;
		3069	end;
		3070
		3071	procedure TCustomDXPaintBox.Paint;
		3072
		3073	procedure Draw2(Width, Height: Integer);
		3074	begin
		3075	if (Width<>FDIB.Width) or (Height<>FDIB.Height) then
		3076	begin
		3077	if FCenter then
		3078	begin
		3079	inherited Canvas.StretchDraw(Bounds(-(Width-ClientWidth) div 2,
		3080	-(Height-ClientHeight) div 2, Width, Height), FDIB);
		3081	end else
		3082	begin
		3083	inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
		3084	end;
		3085	end else
		3086	begin
		3087	if FCenter then
		3088	begin
		3089	inherited Canvas.Draw(-(Width-ClientWidth) div 2, -(Height-ClientHeight) div 2,
		3090	FDIB);
		3091	end else
		3092	begin
		3093	inherited Canvas.Draw(0, 0, FDIB);
		3094	end;
		3095	end;
		3096	end;
		3097
		3098	var
		3099	r, r2: Single;
		3100	ViewWidth2, ViewHeight2: Integer;
		3101	begin
		3102	inherited Paint;
		3103
		3104	with inherited Canvas do
		3105	begin
		3106	if (csDesigning in ComponentState) then
		3107	begin
		3108	Pen.Style := psDash;
		3109	Brush.Style := bsClear;
		3110	Rectangle(0, 0, Width, Height);
		3111	end;
		3112
		3113	if FDIB.Empty then Exit;
		3114
		3115	if (FViewWidth>0) or (FViewHeight>0) then
		3116	begin
		3117	ViewWidth2 := FViewWidth;
		3118	if ViewWidth2=0 then ViewWidth2 := FDIB.Width;
		3119	ViewHeight2 := FViewHeight;
		3120	if ViewHeight2=0 then ViewHeight2 := FDIB.Height;
		3121
		3122	if FAutoStretch then
		3123	begin
		3124	if (ClientWidth<ViewWidth2) or (ClientHeight<ViewHeight2) then
		3125	begin
		3126	r := ViewWidth2/ClientWidth;
		3127	r2 := ViewHeight2/ClientHeight;
		3128	if r>r2 then
		3129	r := r2;
		3130	Draw2(Round(rClientWidth), Round(rClientHeight));
		3131	end else
		3132	Draw2(ViewWidth2, ViewHeight2);
		3133	end else
		3134	Draw2(ViewWidth2, ViewHeight2);
		3135	end else
		3136	begin
		3137	if FAutoStretch then
		3138	begin
		3139	if (FDIB.Width>ClientWidth) or (FDIB.Height>ClientHeight) then
		3140	begin
		3141	r := ClientWidth/FDIB.Width;
		3142	r2 := ClientHeight/FDIB.Height;
		3143	if r>r2 then
		3144	r := r2;
		3145	Draw2(Round(rFDIB.Width), Round(rFDIB.Height));
		3146	end else
		3147	Draw2(FDIB.Width, FDIB.Height);
		3148	end else
		3149	if FStretch then
		3150	begin
		3151	if FKeepAspect then
		3152	begin
		3153	r := ClientWidth/FDIB.Width;
		3154	r2 := ClientHeight/FDIB.Height;
		3155	if r>r2 then
		3156	r := r2;
		3157	Draw2(Round(rFDIB.Width), Round(rFDIB.Height));
		3158	end else
		3159	Draw2(ClientWidth, ClientHeight);
		3160	end else
		3161	Draw2(FDIB.Width, FDIB.Height);
		3162	end;
		3163	end;
		3164	end;
		3165
		3166	procedure TCustomDXPaintBox.SetAutoStretch(Value: Boolean);
		3167	begin
		3168	if FAutoStretch<>Value then
		3169	begin
		3170	FAutoStretch := Value;
		3171	Invalidate;
		3172	end;
		3173	end;
		3174
		3175	procedure TCustomDXPaintBox.SetCenter(Value: Boolean);
		3176	begin
		3177	if FCenter<>Value then
		3178	begin
		3179	FCenter := Value;
		3180	Invalidate;
		3181	end;
		3182	end;
		3183
		3184	procedure TCustomDXPaintBox.SetDIB(Value: TDIB);
		3185	begin
		3186	if FDIB<>Value then
		3187	begin
		3188	FDIB.Assign(Value);
		3189	Invalidate;
		3190	end;
		3191	end;
		3192
		3193	procedure TCustomDXPaintBox.SetKeepAspect(Value: Boolean);
		3194	begin
		3195	if Value<>FKeepAspect then
		3196	begin
		3197	FKeepAspect := Value;
		3198	Invalidate;
		3199	end;
		3200	end;
		3201
		3202	procedure TCustomDXPaintBox.SetStretch(Value: Boolean);
		3203	begin
		3204	if Value<>FStretch then
		3205	begin
		3206	FStretch := Value;
		3207	Invalidate;
		3208	end;
		3209	end;
		3210
		3211	procedure TCustomDXPaintBox.SetViewWidth(Value: Integer);
		3212	begin
		3213	if Value<0 then Value := 0;
		3214	if Value<>FViewWidth then
		3215	begin
		3216	FViewWidth := Value;
		3217	Invalidate;
		3218	end;
		3219	end;
		3220
		3221	procedure TCustomDXPaintBox.SetViewHeight(Value: Integer);
		3222	begin
		3223	if Value<0 then Value := 0;
		3224	if Value<>FViewHeight then
		3225	begin
		3226	FViewHeight := Value;
		3227	Invalidate;
		3228	end;
		3229	end;
		3230
		3231	initialization
		3232	TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
		3233	TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);
		3234	finalization
		3235	TPicture.UnRegisterGraphicClass(TDIB);
		3236
		3237	FEmptyDIBImage.Free;
		3238	FPaletteManager.Free;
		3239	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DIB.pas @ 4 – Rev 1