david
ac9b7c9668
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.jvcl@17 7f62d464-2af8-f54e-996c-e91b33f51cbe
2131 lines
75 KiB
ObjectPascal
2131 lines
75 KiB
ObjectPascal
(*======================================================================*
|
||
| unitExIcon.pas |
|
||
| |
|
||
| Encapsulates Windows Icons & Cursors. |
|
||
| |
|
||
| For icons In TExIconImage, the memory is the bitmapinfo, followed by |
|
||
| the color and mask bits. |
|
||
| |
|
||
| For cursors it is preceeded by word x and y hotspots |
|
||
| |
|
||
| This corresponds with what you find in resources, but not .CUR files |
|
||
| |
|
||
| .CUR files look like .ICO files except: |
|
||
| |
|
||
| 1. The wType is '2' not '1' |
|
||
| |
|
||
| 2. wPlanes and wBitCount contain the X and Y hotspot. Because of |
|
||
| they can only get the color depth from bColorCount, with its |
|
||
| max of 256. |
|
||
| |
|
||
| The contents of this file are subject to the Mozilla Public License |
|
||
| Version 1.1 (the "License"); you may not use this file except in |
|
||
| compliance with the License. You may obtain a copy of the License |
|
||
| at http://www.mozilla.org/MPL/ |
|
||
| |
|
||
| Software distributed under the License is distributed on an "AS IS" |
|
||
| basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See |
|
||
| the License for the specific language governing rights and |
|
||
| limitations under the License. |
|
||
| |
|
||
| Copyright <20> Colin Wilson 2002 All Rights Reserved |
|
||
| |
|
||
| Version Date By Description |
|
||
| ------- ---------- ---- ----------------------------------------- |
|
||
| 1.0 10/10/2000 CPWW Original |
|
||
| 1.01 30/04/2001 CPWW Cursors working |
|
||
| 1.02 17/12/2001 CPWW Bug in displaying icons/cursor in W98 |
|
||
| fixed. |
|
||
*----------------------------------------------------------------------*)
|
||
|
||
unit unitExIcon;
|
||
|
||
interface
|
||
|
||
uses Windows, Classes, SysUtils, Graphics;
|
||
|
||
type
|
||
|
||
//=============================================================================
|
||
// TExIconImage class - Shared image structure for icons & cursors
|
||
// nb. the memory image (and of course, the handle) are for one image only
|
||
|
||
|
||
// TIconHeader is variously called NEWHEADER, ICONDIR and GRPICONDIR in the SDK
|
||
TIconHeader = packed record
|
||
wReserved : word; // Must be 0
|
||
wType : word; // 1 for icons, 2 for cursors
|
||
wCount : word; // Number of components
|
||
end;
|
||
PIconHeader = ^TIconHeader;
|
||
|
||
// TResourceDirectory is called RESDIR in the SDK.
|
||
TResourceDirectory = packed record
|
||
details : packed record case boolean of
|
||
False : (cursorWidth, cursorHeight : word);
|
||
True : (iconWidth, iconHeight, iconColorCount, iconReserved : BYTE)
|
||
end;
|
||
wPlanes, wBitCount : word;
|
||
lBytesInRes : DWORD;
|
||
wNameOrdinal : word
|
||
end;
|
||
PResourceDirectory = ^TResourceDirectory;
|
||
|
||
// TIconDirEntry is called ICONDIRENTRY in the SDK
|
||
TIconDirEntry = packed record
|
||
bWidth : BYTE; // Width, in pixels, of the image
|
||
bHeight : BYTE; // Height, in pixels, of the image
|
||
bColorCount : BYTE; // Number of colors in image (0 if >=8bpp)
|
||
bReserved : BYTE; // Reserved ( must be 0)
|
||
wPlanes : WORD; // Color Planes (X Hotspot for cursors)
|
||
wBitCount : WORD; // Bits per pixel (Y Hotspot for cursors - implies MAX 256 color cursors (!))
|
||
dwBytesInRes : DWORD; // How many bytes in this resource?
|
||
dwImageOffset : DWORD; // Where in the file is this image?
|
||
end;
|
||
PIconDirEntry = ^TIconDirEntry;
|
||
|
||
//-----------------------------------------------------------------------------
|
||
// TExIconImage
|
||
//
|
||
// Each ExIconCursor can have multiple TExIconImage classes - one per format in
|
||
// the ICO file or Icon resource/
|
||
|
||
TExIconImage = class (TSharedImage)
|
||
FIsIcon : boolean;
|
||
FHandle: HICON;
|
||
FPalette : HPALETTE;
|
||
FMemoryImage: TCustomMemoryStream;
|
||
FGotPalette : boolean; // Indicates that we've got a the palette from the image data
|
||
// or that there is no palette (eg. it's not pf1bit ..pf8Bit)
|
||
|
||
FWidth, FHeight : Integer;
|
||
FPixelFormat : TPixelFormat;
|
||
|
||
procedure HandleNeeded;
|
||
procedure PaletteNeeded;
|
||
procedure ImageNeeded;
|
||
|
||
function GetBitmapInfo : PBitmapInfo;
|
||
function GetBitmapInfoHeader : PBitmapInfoHeader;
|
||
private
|
||
function GetMemoryImage: TCustomMemoryStream;
|
||
|
||
protected
|
||
procedure FreeHandle; override;
|
||
public
|
||
destructor Destroy; override;
|
||
|
||
property Handle : HICON read fHandle; // The Icon image handle
|
||
property PaletteHandle : HPALETTE read fPalette; // The Icon image's palette
|
||
|
||
property Width : Integer read FWidth;
|
||
property Height : Integer read FHeight;
|
||
property PixelFormat : TPixelFormat read FPixelFormat;
|
||
property MemoryImage : TCustomMemoryStream read GetMemoryImage;
|
||
end;
|
||
|
||
//-----------------------------------------------------------------------------
|
||
// TExIconCursor
|
||
|
||
TExIconCursor = class (TGraphic)
|
||
private
|
||
FImages : array of TExIconImage;
|
||
FCurrentImage : Integer;
|
||
FTransparentColor: TColor;
|
||
|
||
function GetHandle: HICON;
|
||
function GetPixelFormat: TPixelFormat;
|
||
procedure SetPixelFormat(const Value: TPixelFormat);
|
||
function GetImageCount: Integer;
|
||
|
||
procedure ReleaseImages;
|
||
function GetImage(index: Integer): TExIconImage;
|
||
procedure SetHandle(const Value: HICON);
|
||
procedure AssignFromGraphic (source : TGraphic);
|
||
procedure SetCurrentImage(const Value: Integer);
|
||
|
||
procedure HandleNeeded;
|
||
procedure PaletteNeeded;
|
||
procedure ImageNeeded;
|
||
procedure ReadIcon (instance : THandle; stream : TCustomMemoryStream; Size : Integer);
|
||
protected
|
||
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
|
||
function GetEmpty: Boolean; override;
|
||
function GetHeight: Integer; override;
|
||
function GetWidth: Integer; override;
|
||
procedure SetHeight(Value: Integer); override;
|
||
procedure SetWidth(Value: Integer); override;
|
||
procedure SetPalette(Value: HPALETTE); override;
|
||
function GetTransparent : boolean; override;
|
||
function GetPalette : HPALETTE; override;
|
||
|
||
public
|
||
constructor Create; override;
|
||
destructor Destroy; override;
|
||
procedure LoadFromStream(Stream: TStream); override;
|
||
procedure SaveToStream(Stream: TStream); override;
|
||
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;
|
||
procedure LoadFromResourceName (Instance : THandle; const resName : string);
|
||
procedure LoadFromResourceId (Instance : THandle; ResID : Integer);
|
||
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;
|
||
procedure Assign (source : TPersistent); override;
|
||
procedure AssignTo (dest : TPersistent); override;
|
||
function Releasehandle : HICON;
|
||
|
||
procedure SaveImageToFile (const FileName : string);
|
||
|
||
// Save just the current image - SaveToFile saves all the images.
|
||
|
||
|
||
property Handle: HICON read GetHandle write SetHandle;
|
||
property PixelFormat : TPixelFormat read GetPixelFormat write SetPixelFormat;
|
||
property ImageCount : Integer read GetImageCount;
|
||
property Images [index : Integer] : TExIconImage read GetImage;
|
||
|
||
property CurrentImage : Integer read fCurrentImage write SetCurrentImage;
|
||
property TransparentColor : TColor read fTransparentColor write fTransparentColor;
|
||
end;
|
||
|
||
//-----------------------------------------------------------------------------
|
||
// TExIcon
|
||
|
||
TExIcon = class (TExIconCursor)
|
||
protected
|
||
public
|
||
constructor Create; override;
|
||
end;
|
||
|
||
//-----------------------------------------------------------------------------
|
||
// TExCursor
|
||
|
||
TExCursor = class (TExIconCursor)
|
||
private
|
||
function GetHotspot: DWORD;
|
||
procedure SetHotspot(const Value: DWORD);
|
||
protected
|
||
public
|
||
constructor Create; override;
|
||
property Hotspot : DWORD read GetHotspot write SetHotspot;
|
||
|
||
// nb. .CUR file format is not the same as resource stream format !!!!
|
||
|
||
procedure LoadFromFile (const FileName : string); override;
|
||
procedure SaveToFile (const FileName : string); override;
|
||
end;
|
||
|
||
function GetPixelFormatNumColors (pf : TPixelFormat) : Integer;
|
||
function GetPixelFormatBitCount (pf : TPixelFormat) : Integer;
|
||
|
||
function CreateMappedBitmap (source : TGraphic; palette : HPALETTE; hiPixelFormat : TPixelFormat; Width, Height : Integer) : TBitmap;
|
||
function GetBitmapInfoNumColors (const BI : TBitmapInfoHeader) : Integer;
|
||
function GetBitmapInfoPixelFormat (const BI : TBitmapInfoHeader) : TPixelFormat;
|
||
procedure GetBitmapInfoSizes (const BI : TBitmapInfoHeader; var InfoHeaderSize, ImageSize : DWORD; iconInfo : boolean);
|
||
function GetPixelFormat (graphic : TGraphic) : TPixelFormat;
|
||
|
||
var
|
||
SystemPalette256 : HPALETTE; // 256 color 'web' palette.
|
||
SystemPalette2 : HPALETTE;
|
||
|
||
implementation
|
||
|
||
uses Clipbrd;
|
||
|
||
resourceString
|
||
rstInvalidIcon = 'Invalid Icon or Cursor';
|
||
rstInvalidCursor = 'Invalid cursor';
|
||
rstInvalidBitmap = 'Invalid Bitmap';
|
||
rstInvalidPixelFormat = 'Pixel Format Not Valid for Icons or Cursors';
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| GetPixelFormatNumColors |
|
||
| |
|
||
| Get number of colors for a pixel format. 0 if > pf8bit |
|
||
*----------------------------------------------------------------------*)
|
||
function GetPixelFormatNumColors (pf : TPixelFormat) : Integer;
|
||
begin
|
||
case pf of
|
||
pf1Bit : Result := 2;
|
||
pf4Bit : Result := 16;
|
||
pf8Bit : Result := 256;
|
||
else
|
||
Result := 0
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| GetPixelFormatBitCount |
|
||
| |
|
||
| Get number of bits per pixel for a pixel format |
|
||
*----------------------------------------------------------------------*)
|
||
function GetPixelFormatBitCount (pf : TPixelFormat) : Integer;
|
||
begin
|
||
case pf of
|
||
pf1Bit : Result := 1;
|
||
pf4Bit : Result := 4;
|
||
pf8Bit : Result := 8;
|
||
pf15Bit : Result := 16; // 16 bpp RGB. 1 unused, 5 R, 5 G, 5 B
|
||
pf16Bit : Result := 16; // 16 bpp BITFIELDS
|
||
pf24Bit : Result := 24;
|
||
pf32Bit : Result := 32 // Either RGB (8 unused, 8 R, 8 G, 8 B) or 32 bit BITFIELDS
|
||
else
|
||
Result := 0
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| GetPixelFormat |
|
||
| |
|
||
| Get our pixel format. |
|
||
*----------------------------------------------------------------------*)
|
||
function GetPixelFormat (graphic : TGraphic) : TPixelFormat;
|
||
begin
|
||
if graphic is TBitmap then
|
||
Result := TBitmap (graphic).PixelFormat
|
||
else
|
||
if graphic is TExIconCursor then
|
||
Result := TExIconCursor (graphic).PixelFormat
|
||
else
|
||
Result := pfDevice
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function GDICheck() |
|
||
| |
|
||
| Check GDI APIs |
|
||
*----------------------------------------------------------------------------*)
|
||
function GDICheck(Value: HGDIOBJ): HGDIOBJ;
|
||
begin
|
||
if Value = 0 then
|
||
RaiseLastOSError;
|
||
Result := Value;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure InitializeBitmapInfoHeader () |
|
||
| |
|
||
| Initialize a TBitmapInfoHeader from a DIB or DDB bitmap |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader; PixelFormat : TPixelFormat);
|
||
var
|
||
DS: TDIBSection;
|
||
Bytes: Integer;
|
||
begin
|
||
DS.dsbmih.biSize := 0;
|
||
Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
|
||
if Bytes = 0 then
|
||
raise EInvalidGraphic.Create (rstInvalidBitmap);
|
||
|
||
if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
|
||
(DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
|
||
BI := DS.dsbmih // It was a DIB bitmap
|
||
else
|
||
begin // It was a DDB bitmap
|
||
FillChar(BI, sizeof(BI), 0);
|
||
with BI, DS.dsbm do
|
||
begin
|
||
biSize := SizeOf(BI);
|
||
biWidth := bmWidth;
|
||
biHeight := bmHeight;
|
||
end;
|
||
end;
|
||
|
||
if PixelFormat in [pf1Bit..pf8Bit] then
|
||
begin
|
||
BI.biBitCount := GetPixelFormatBitCount (PixelFormat);
|
||
BI.biClrUsed := GetPixelFormatNumColors (PixelFormat)
|
||
end
|
||
else
|
||
begin
|
||
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
|
||
case DS.dsBm.bmBitsPixel of
|
||
1 : BI.biClrUsed := 2;
|
||
4 : BI.biClrUsed := 16;
|
||
8 : BI.biClrUsed := 256
|
||
end
|
||
end;
|
||
|
||
BI.biPlanes := 1;
|
||
if BI.biClrImportant > BI.biClrUsed then
|
||
BI.biClrImportant := BI.biClrUsed;
|
||
|
||
BI.biSizeImage := 0; // SDK sample IconPro always sets biSizeImage to 0. It
|
||
// seems to be safer to calculate the size from hight * bytes per
|
||
// scan line. So we'll do the same...
|
||
end;
|
||
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function GetBitmapInfoNumColors |
|
||
| |
|
||
| Get the number of colors (0, 2..256) of a bitmap header. |
|
||
*----------------------------------------------------------------------------*)
|
||
function GetBitmapInfoNumColors (const BI : TBitmapInfoHeader) : Integer;
|
||
begin
|
||
if BI.biBitCount <= 8 then
|
||
if BI.biClrUsed > 0 then
|
||
result := BI.biClrUsed
|
||
else
|
||
result := 1 shl BI.biBitCount
|
||
else
|
||
result := 0;
|
||
end;
|
||
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function GetBitmapInfoPixelFormat |
|
||
| |
|
||
| Get the pixel format of a bitmap header. |
|
||
*----------------------------------------------------------------------------*)
|
||
function GetBitmapInfoPixelFormat (const BI : TBitmapInfoHeader) : TPixelFormat;
|
||
begin
|
||
case BI.biBitCount of
|
||
1: result := pf1Bit;
|
||
4: result := pf4Bit;
|
||
8: result := pf8Bit;
|
||
16: case BI.biCompression of
|
||
BI_RGB : result := pf15Bit;
|
||
BI_BITFIELDS: result := pf16Bit;
|
||
else
|
||
raise EInvalidGraphic.Create (rstInvalidPixelFormat);
|
||
end;
|
||
24: result := pf24Bit;
|
||
32: result := pf32Bit;
|
||
else
|
||
raise EInvalidGraphic.Create (rstInvalidPixelFormat);
|
||
end
|
||
end;
|
||
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure GetBitmapInfoSizes |
|
||
| |
|
||
| Get the size of the info (incl the colortable), and the bitmap bits |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure GetBitmapInfoSizes (const BI : TBitmapInfoHeader; var InfoHeaderSize, ImageSize : DWORD; iconInfo : boolean);
|
||
var
|
||
numColors : Integer;
|
||
height : Integer;
|
||
begin
|
||
InfoHeaderSize := SizeOf (TBitmapInfoHeader);
|
||
|
||
numColors := GetBitmapInfoNumColors (bi);
|
||
|
||
if numColors > 0 then
|
||
Inc (InfoHeaderSize, SizeOf(TRGBQuad) * NumColors)
|
||
else
|
||
if (BI.biCompression and BI_BITFIELDS) <> 0 then
|
||
Inc(InfoHeaderSize, 12);
|
||
|
||
height := Abs(BI.biHeight);
|
||
if iconInfo then height := height shr 1;
|
||
ImageSize := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Height
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure InternalGetDIBSizes () |
|
||
| |
|
||
| Get size of bitmap header (incl. color table) and bitmap bits. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
|
||
var ImageSize: DWORD; PixelFormat : TPixelFormat);
|
||
var
|
||
BI: TBitmapInfoHeader;
|
||
begin
|
||
InitializeBitmapInfoHeader(Bitmap, BI, PixelFormat);
|
||
GetBitmapInfoSizes (BI, InfoHeaderSize, ImageSize, False);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure InternalGetDIB () |
|
||
| |
|
||
| Get bitmap bits. Note that we *always* call this on a bitmap with the |
|
||
| required colour depth - ie. we don't use this to do mapping. |
|
||
| |
|
||
| We (therefore) don't use GetDIBits here to get the colour table. |
|
||
*----------------------------------------------------------------------------*)
|
||
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
|
||
BitmapInfo : PBitmapInfo; var Bits; PixelFormat : TPixelFormat): Boolean;
|
||
var
|
||
OldPal: HPALETTE;
|
||
DC: HDC;
|
||
begin
|
||
InitializeBitmapInfoHeader(Bitmap, BitmapInfo^.bmiHeader, PixelFormat);
|
||
OldPal := 0;
|
||
DC := CreateCompatibleDC(0);
|
||
try
|
||
if Palette <> 0 then
|
||
begin
|
||
OldPal := SelectPalette(DC, Palette, False);
|
||
RealizePalette(DC);
|
||
end;
|
||
Result := GetDIBits(DC, Bitmap, 0, BitmapInfo^.bmiHeader.biHeight, @Bits, BitmapInfo^, DIB_RGB_COLORS) <> 0;
|
||
finally
|
||
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
|
||
DeleteDC(DC);
|
||
end;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure CreateDIBPalette () |
|
||
| |
|
||
| Create the palette from bitmap info. |
|
||
*----------------------------------------------------------------------------*)
|
||
function CreateDIBPalette (const bmi : TBitmapInfo) : HPalette;
|
||
var
|
||
lpPal : PLogPalette;
|
||
i : Integer;
|
||
numColors : Integer;
|
||
r : RGBQUAD;
|
||
begin
|
||
result := 0;
|
||
|
||
NumColors := GetBitmapInfoNumColors (bmi.bmiHeader);
|
||
|
||
if NumColors > 0 then
|
||
begin
|
||
if NumColors = 1 then
|
||
result := CopyPalette (SystemPalette2)
|
||
else
|
||
begin
|
||
GetMem (lpPal, sizeof (TLogPalette) + sizeof (TPaletteEntry) * NumColors);
|
||
try
|
||
lpPal^.palVersion := $300;
|
||
lpPal^.palNumEntries := NumColors;
|
||
|
||
{$R-}
|
||
for i := 0 to NumColors -1 do
|
||
begin
|
||
r := bmi.bmiColors [i];
|
||
lpPal^.palPalEntry[i].peRed := bmi.bmiColors [i].rgbRed;
|
||
lpPal^.palPalEntry[i].peGreen := bmi.bmiColors[i].rgbGreen;
|
||
lpPal^.palPalEntry[i].peBlue := bmi.bmiColors[i].rgbBlue;
|
||
lpPal^.palPalEntry[i].peFlags := 0 // not bmi.bmiColors[i].rgbReserved !!
|
||
end;
|
||
{$R+}
|
||
result := CreatePalette (lpPal^)
|
||
finally
|
||
FreeMem (lpPal)
|
||
end
|
||
end
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure CreateMappedBitmap |
|
||
| |
|
||
| Copy a graphic to a DIB bitmap with the specified palette or color |
|
||
| format, and size. |
|
||
| |
|
||
| If the palette is 0, the returned bitmap's pixelformat is hiPixelFormat |
|
||
| otherwise the returned bitmap's pixel format is set so it's correct for |
|
||
| the number of colors in the palette. |
|
||
*----------------------------------------------------------------------------*)
|
||
function CreateMappedBitmap (source : TGraphic; palette : HPALETTE; hiPixelFormat : TPixelFormat; Width, Height : Integer) : TBitmap;
|
||
var
|
||
colorCount : Integer;
|
||
begin
|
||
result := TBitmap.Create;
|
||
result.Width := source.Width;
|
||
result.Height := source.Height;
|
||
|
||
if palette <> 0 then
|
||
begin
|
||
colorCount := 0;
|
||
if GetObject (palette, sizeof (colorCount), @colorCount) = 0 then
|
||
RaiseLastOSError;
|
||
|
||
case colorCount of
|
||
1..2 : result.PixelFormat := pf1Bit;
|
||
3..16 : result.PixelFormat := pf4Bit;
|
||
17..256 : result.PixelFormat := pf8Bit;
|
||
else
|
||
result.PixelFormat := hiPixelFormat;
|
||
end;
|
||
|
||
result.Palette := CopyPalette (palette);
|
||
|
||
result.Canvas.StretchDraw (rect (0, 0, Width, Height), source);
|
||
end
|
||
else
|
||
begin
|
||
result.PixelFormat := hiPixelFormat;
|
||
result.Canvas.StretchDraw (rect (0, 0, Width, Height), source);
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure MaskBitmapBits |
|
||
| |
|
||
| Kinda like MaskBlt - but without the bugs. SLOW. Maybe I'll revisit this |
|
||
| use bitblt instead... |
|
||
| |
|
||
| But see MSDN PRB: Trouble Using DIBSection as a Monochrome Mask |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure MaskBitmapBits (bits : PChar; pixelFormat : TPixelFormat; mask : PChar; width, height : DWORD; palette : HPalette);
|
||
var
|
||
bpScanline, maskbpScanline : Integer;
|
||
bitsPerPixel, i, j : Integer;
|
||
maskbp, bitbp : byte;
|
||
maskp, bitp : PChar;
|
||
maskPixel : boolean;
|
||
maskByte: dword;
|
||
maskU : UINT;
|
||
maskColor : byte;
|
||
maskColorByte : byte;
|
||
begin
|
||
// Get 'black' color index. This is usually 0
|
||
// but some people play jokes...
|
||
|
||
if palette <> 0 then
|
||
begin
|
||
maskU := GetNearestPaletteIndex (palette, RGB (0, 0, 0));
|
||
if maskU = CLR_INVALID then
|
||
RaiseLastOSError;
|
||
|
||
maskColor := maskU
|
||
end
|
||
else
|
||
maskColor := 0;
|
||
|
||
bitsPerPixel := GetPixelFormatBitCount (PixelFormat);
|
||
if bitsPerPixel = 0 then
|
||
raise EInvalidGraphic.Create (rstInvalidPixelFormat);
|
||
|
||
// Get byte count for mask and bitmap
|
||
// scanline. Can be weird because of padding.
|
||
|
||
bpScanline := BytesPerScanLine(width, bitsPerPixel, 32);
|
||
maskbpScanline := BytesPerScanline (width, 1, 32);
|
||
|
||
maskByte := $ffffffff; // Set constant values for 8bpp masks
|
||
maskColorByte := maskColor;
|
||
|
||
for i := 0 to height - 1 do // Go thru each scanline...
|
||
begin
|
||
|
||
maskbp := 0; // Bit offset in current mask byte
|
||
bitbp := 0; // Bit offset in current bitmap byte
|
||
maskp := mask; // Pointer to current mask byte
|
||
bitp := bits; // Pointer to current bitmap byte;
|
||
|
||
for j := 0 to width - 1 do // Go thru each pixel
|
||
begin
|
||
// Pixel should be masked?
|
||
maskPixel := (byte (maskp^) and ($80 shr maskbp)) <> 0;
|
||
if maskPixel then
|
||
begin
|
||
case bitsPerPixel of
|
||
1, 4, 8 :
|
||
begin
|
||
case bitsPerPixel of // Calculate bit mask and 'black' color bits
|
||
1 :
|
||
begin
|
||
maskByte := $80 shr bitbp;
|
||
maskColorByte := maskColor shl (7 - bitbp);
|
||
end;
|
||
|
||
4 :
|
||
begin
|
||
maskByte := $f0 shr bitbp;
|
||
maskColorByte := maskColor shl (4 - bitbp)
|
||
end
|
||
end;
|
||
// Apply the mask
|
||
bitp^ := char ((byte (bitp^) and (not maskByte)) or maskColorByte);
|
||
end;
|
||
|
||
15, 16 :
|
||
PWORD (bitp)^ := $0000;
|
||
|
||
24 :
|
||
begin
|
||
PWORD (bitp)^ := $0000;
|
||
PBYTE (bitp + sizeof (WORD))^ := $00
|
||
end;
|
||
|
||
32 :
|
||
PDWORD (bitp)^ := $ffffffff;
|
||
end
|
||
end;
|
||
|
||
Inc (maskbp); // Next mask bit
|
||
if maskbp = 8 then
|
||
begin
|
||
maskbp := 0;
|
||
Inc (maskp) // Next mask byte
|
||
end;
|
||
|
||
Inc (bitbp, bitsPerPixel); // Next bitmap bit(s)
|
||
while bitbp >= 8 do
|
||
begin
|
||
Dec (bitbp, 8);
|
||
Inc (bitp) // Next bitmap byte
|
||
end
|
||
end;
|
||
|
||
Inc (mask, maskbpScanline); // Set mask for start of next line
|
||
Inc (bits, bpScanLine) // Set bits to start of next line
|
||
end
|
||
end;
|
||
|
||
{ TExIconCursor }
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIcon.Assign |
|
||
| |
|
||
| Assign an TExIcon from another graphic. |
|
||
| |
|
||
| A bit of a compromise this... |
|
||
| |
|
||
| ... if source is a TExIcon then all images get replaced by the source |
|
||
| images. |
|
||
| |
|
||
| ... Otherwise only the CurrentImage gets replaced |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.Assign(source: TPersistent);
|
||
var
|
||
i : Integer;
|
||
src : TExIconCursor;
|
||
image : TExIconImage;
|
||
data : THandle;
|
||
begin
|
||
if source is TExIconCursor then
|
||
begin // Share all images from the source TExIcon
|
||
src := TExIconCursor (source);
|
||
FTransparentColor := src.TransparentColor;
|
||
|
||
ReleaseImages;
|
||
SetLength (fImages, src.ImageCount);
|
||
|
||
for i := 0 to ImageCount - 1 do
|
||
begin
|
||
src.Images [i].Reference;
|
||
fImages [i] := src.Images [i]
|
||
end;
|
||
|
||
fCurrentImage := src.FCurrentImage;
|
||
Changed(Self);
|
||
end
|
||
else
|
||
if source = Nil then // Clear the current image.
|
||
begin
|
||
image := TExIconImage.Create;
|
||
image.FIsIcon := Images [FCurrentImage].FIsIcon;
|
||
image.FWidth := Images [FCurrentImage].Width;
|
||
image.FHeight := Images [FCurrentImage].Height;
|
||
image.FPixelFormat := Images [FCurrentImage].PixelFormat;
|
||
|
||
Images [fCurrentImage].Release;
|
||
FImages [FCurrentImage] := image;
|
||
image.Reference;
|
||
Changed(Self);
|
||
end
|
||
else
|
||
if source is TGraphic then // Copy from other graphic (TBitmap, etc)
|
||
AssignFromGraphic (TGraphic (source))
|
||
else
|
||
if source is TClipboard then
|
||
begin
|
||
clipboard.Open;
|
||
try
|
||
Data := GetClipboardData(CF_DIB);
|
||
LoadFromClipboardFormat(CF_DIB, Data, 0);
|
||
finally
|
||
clipboard.Close
|
||
end;
|
||
end
|
||
else
|
||
inherited Assign (source)
|
||
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.AssignFromGraphic |
|
||
| |
|
||
| Assign an TExIcon from another graphic, converting it to our pixel format |
|
||
| and palette. |
|
||
| |
|
||
| Internal use only! |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.AssignFromGraphic (source : TGraphic);
|
||
var
|
||
src, maskBmp : TBitmap;
|
||
offset, infoHeaderSize, imageSize, maskImageSize : DWORD;
|
||
colorBits, maskBits : PChar;
|
||
image : TExIconImage;
|
||
info : PBitmapInfo;
|
||
maskInfo : PBitmapInfo;
|
||
dc : HDC;
|
||
begin
|
||
src := Nil;
|
||
maskBmp := TBitmap.Create;
|
||
|
||
try
|
||
// Get a bitmap with the required format
|
||
src := CreateMappedBitmap (source, Palette, PixelFormat, Width, height);
|
||
|
||
maskBmp.Assign (source); // Get mask bitmap - White where the transparent color
|
||
// occurs - otherwise black.
|
||
|
||
if source is TBitmap then
|
||
maskBmp.Mask (TBitmap (source).transparentColor)
|
||
else
|
||
if Source is TExIconCursor then
|
||
maskBmp.Mask (TExIconCursor(source).transparentColor)
|
||
else
|
||
maskBmp.Mask (clBlack);
|
||
|
||
// Get size for mask bits buffer
|
||
maskImageSize := BytesPerScanLine (Width, 1, 32) * Height;
|
||
|
||
// Get size for color bits buffer
|
||
InternalGetDibSizes (src.Handle, infoHeaderSize, imageSize, PixelFormat);
|
||
|
||
// Create a memory stream to assemble the icon image
|
||
image := TExIconImage.Create;
|
||
try
|
||
image.Reference;
|
||
image.FMemoryImage := TMemoryStream.Create;
|
||
image.FIsIcon := Self is TExIcon;
|
||
|
||
if image.FIsIcon then
|
||
offset := 0
|
||
else
|
||
offset := sizeof (DWORD);
|
||
|
||
image.FMemoryImage.Size := infoHeaderSize + imageSize + maskImageSize + offset;
|
||
|
||
info := PBitmapInfo (PChar (image.FMemoryImage.Memory) + offset);
|
||
colorBits := PChar (info) + infoHeaderSize;
|
||
maskBits := colorBits + imageSize;
|
||
|
||
InternalGetDib (src.Handle, Palette, info, colorBits^, PixelFormat);
|
||
// Get the bitmap header, palette & bits
|
||
|
||
|
||
maskInfo := nil;
|
||
dc := CreateCompatibleDC (0);
|
||
try
|
||
GetMem (maskInfo, SizeOf (TBitmapInfoHeader) + 2 * SizeOf (RGBQUAD));
|
||
// Get mask bits
|
||
|
||
with maskInfo^.bmiHeader do // Set the 1st six members of info header, according
|
||
begin // to the docs.
|
||
|
||
biSize := SizeOf (TBitmapInfoHeader);
|
||
biWidth := Width;
|
||
biHeight := Height;
|
||
biBitCount := 1;
|
||
biPlanes := 1;
|
||
biCompression := BI_RGB;
|
||
end;
|
||
|
||
if GetDIBits (dc, maskBmp.Handle, 0, Height, maskBits, maskInfo^, DIB_RGB_COLORS) = 0 then
|
||
RaiseLastOSError;
|
||
finally
|
||
DeleteDC (dc);
|
||
FreeMem (maskInfo)
|
||
end;
|
||
|
||
MaskBitmapBits (colorBits, PixelFormat, maskBits, Width, Height, Palette);
|
||
|
||
image.FWidth := info^.bmiHeader.biWidth;
|
||
image.FHeight := info^.bmiHeader.biHeight;
|
||
|
||
info^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2;
|
||
// Adjust height for funky icon Height thing.
|
||
|
||
image.FPixelFormat := src.PixelFormat;
|
||
|
||
image.FGotPalette := False; // ie. we need to get it later if required.
|
||
|
||
if Self is TExCursor then
|
||
PDWORD (image.FMemoryImage.Memory)^ := TExCursor (Self).HotSpot;
|
||
|
||
Images [fCurrentImage].Release;
|
||
fImages [fCurrentImage] := Image;
|
||
Changed (self);
|
||
except
|
||
image.Free;
|
||
raise
|
||
end;
|
||
finally
|
||
maskBmp.Free;
|
||
src.Free
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.AssignTo |
|
||
| |
|
||
| Allow assigning to bitmap |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.AssignTo(dest: TPersistent);
|
||
var
|
||
bmp : TBitmap;
|
||
begin
|
||
if dest is TBitmap then
|
||
begin
|
||
bmp := TBitmap (dest);
|
||
bmp.Assign (nil); // You gotta do this, otherwise transparency goes nuts!
|
||
bmp.PixelFormat := pf24Bit; // Always assign to 24-bit Bitmap so we don't lose colors
|
||
|
||
bmp.Width := Width;
|
||
bmp.Height := Height;
|
||
|
||
bmp.Transparent := True;
|
||
bmp.TransparentColor := TransparentColor;
|
||
bmp.Canvas.Brush.Color := TransparentColor;
|
||
bmp.Canvas.FillRect (RECT (0, 0, Width, Height));
|
||
bmp.Canvas.Draw (0, 0, self);
|
||
end
|
||
else
|
||
inherited AssignTo (dest)
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| constructor TExIconCursor.Create |
|
||
| |
|
||
| Constructor for TExICon |
|
||
*----------------------------------------------------------------------------*)
|
||
constructor TExIconCursor.Create;
|
||
begin
|
||
inherited Create;
|
||
FTransparentColor := RGB ($fe, $e6, $f8);
|
||
SetLength (FImages, 1);
|
||
FImages [0] := TExIconImage.Create;
|
||
FImages [0].FIsIcon := self is TExIcon;
|
||
Images [0].Reference;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| destructor TExIconCursor.Destroy |
|
||
| |
|
||
| destructor for TExIconCursor |
|
||
*----------------------------------------------------------------------------*)
|
||
destructor TExIconCursor.Destroy;
|
||
begin
|
||
ReleaseImages;
|
||
inherited Destroy
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.Draw |
|
||
| |
|
||
| We should be able to do HandleNeeded/DrawIconEx, however we don't want to |
|
||
| call 'HandleNeeded' because of NT bugs, so jump through hoops to draw |
|
||
| direct from the memory image instead. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.Draw(ACanvas: TCanvas; const Rect: TRect);
|
||
var
|
||
monoBmp, oldMonoBmp : HBITMAP;
|
||
colorBmp, oldColorBmp : HBITMAP;
|
||
colorDC, monoDC, dc : HDC;
|
||
bitsOffset, bitsSize : DWORD;
|
||
info : PBitmapInfo;
|
||
hdr : PBitmapInfoHeader;
|
||
monoInfo : PBitmapInfo;
|
||
bits : PChar;
|
||
|
||
begin
|
||
with fImages [fCurrentImage] do
|
||
if Assigned (fMemoryImage) then
|
||
begin
|
||
info := GetBitmapInfo;
|
||
hdr := @info^.bmiHeader;
|
||
|
||
colorBmp := 0;
|
||
monoBmp := 0;
|
||
oldColorBmp := 0;
|
||
oldMonoBmp := 0;
|
||
monoDC := 0;
|
||
colorDC := 0;
|
||
monoInfo := Nil;
|
||
|
||
dc := GDICheck (GetDC (0));
|
||
try
|
||
hdr^.biHeight := hdr^.biHeight div 2; // Adjust memory image for funky Icon Height thing.
|
||
|
||
GetBitmapInfoSizes (hdr^, bitsOffset, bitsSize, False);
|
||
|
||
// Create Color Bitmap from Color bits & ColorTable
|
||
colorBmp := GDICheck (CreateDIBitmap (dc, info^.bmiHeader, CBM_INIT, PChar (info) + bitsOffset, info^, DIB_RGB_COLORS));
|
||
colorDC := GDICheck (CreateCompatibleDC (0));
|
||
oldColorBmp := GDICheck (SelectObject(colorDC, colorBmp));
|
||
|
||
// Create mono bitmap. For some reason, CreateBitmap
|
||
// creates it upside down if you give it the bits - so
|
||
// you have to do CreateBitmap followed by SetDIBtes
|
||
|
||
GetMem (monoInfo, sizeof (TBitmapInfoHeader) + 2 * sizeof (RGBQUAD));
|
||
Move (hdr^, monoInfo^, sizeof (TBitmapInfoHeader));
|
||
monoInfo^.bmiHeader.biBitCount := 1;
|
||
monoInfo^.bmiHeader.biCompression := 0;
|
||
with PRGBQUAD (PChar (monoInfo) + sizeof (TBitmapInfoHeader) + sizeof (RGBQUAD))^ do
|
||
begin
|
||
rgbRed := $ff;
|
||
rgbGreen := $ff;
|
||
rgbBlue := $ff;
|
||
rgbReserved := 0;
|
||
end;
|
||
|
||
monoBmp := GDICheck (CreateBitmap (hdr^.biWidth, hdr^.biHeight, 1, 1, Nil));
|
||
bits := PChar (info) + bitsOffset + bitsSize;
|
||
monoDC := GDICheck (CreateCompatibleDC (0));
|
||
GDICheck (SetDIBits (monoDC, monoBmp, 0, hdr^.biHeight, bits, monoInfo^, DIB_RGB_COLORS));
|
||
oldMonoBmp := GDICheck (SelectObject(monoDC, monoBmp));
|
||
|
||
// Draw the masked bitmap
|
||
|
||
with rect do TransparentStretchBlt (ACanvas.Handle,
|
||
left, top, right - left, bottom - top,
|
||
colorDC, 0, 0,
|
||
hdr^.biWidth, hdr^.biHeight, monoDC, 0, 0);
|
||
|
||
finally
|
||
hdr^.biHeight := hdr^.biHeight * 2;
|
||
|
||
if oldMonoBmp <> 0 then SelectObject (monoDC, oldMonoBmp);
|
||
if monoDC <> 0 then DeleteDC (monoDC);
|
||
|
||
if oldColorBmp <> 0 then SelectObject (colorDC, oldColorBmp);
|
||
if colorDC <> 0 then DeleteDC (colorDC);
|
||
|
||
if colorBmp <> 0 then DeleteObject (colorBmp);
|
||
if monoBmp <> 0 then DeleteObject (monoBmp);
|
||
ReleaseDC (0, dc);
|
||
if monoInfo <> Nil then FreeMem (monoInfo)
|
||
end
|
||
end
|
||
else
|
||
begin
|
||
|
||
// If you've fed an HICON in directly to the handle property you'll get here.
|
||
// DrawIconEx seems to work - it's CreateIconFromresourceex that blows up...
|
||
|
||
if Handle <> 0 then
|
||
with rect do DrawIconEx (ACanvas.Handle, left, top, Handle, right - left, bottom - top, 0, 0, DI_NORMAL)
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetEmpty |
|
||
| |
|
||
| Returns true if the TExIconCursor's current image has neither a handle or |
|
||
| an image |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetEmpty: Boolean;
|
||
begin
|
||
with FImages [fCurrentImage] do
|
||
Result := (FHandle = 0) and (FMemoryImage = nil);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetHandle |
|
||
| |
|
||
| Returns the current image's icon handle. Calls HandleNeeded which may not |
|
||
| be reliable under NT. |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetHandle: HICON;
|
||
begin
|
||
HandleNeeded;
|
||
result := Images [fCurrentImage].Handle
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetHeight |
|
||
| |
|
||
| Returns the current image's height in pixels |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetHeight: Integer;
|
||
begin
|
||
result := FImages [fCurrentImage].FHeight;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetImage |
|
||
| |
|
||
| Get the current image TExIconImage instance |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetImage(index: Integer): TExIconImage;
|
||
begin
|
||
result := fImages [index]
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetImageCount |
|
||
| |
|
||
| Get the nuber of images in the current icon or cursor |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetImageCount: Integer;
|
||
begin
|
||
result := Length (fImages);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetPalette |
|
||
| |
|
||
| Get the palette handle for the current image |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetPalette: HPALETTE;
|
||
begin
|
||
PaletteNeeded;
|
||
result := FImages [fCurrentImage].fPalette;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetPixelFormat : TPixelFormat |
|
||
| |
|
||
| Get the pixel format for the current image |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetPixelFormat: TPixelFormat;
|
||
begin
|
||
result := FImages [fCurrentImage].fPixelFormat
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetTransparent : boolean |
|
||
| |
|
||
| Overrides TGraphic method to always return TRUE |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetTransparent: boolean;
|
||
begin
|
||
result := True
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| function TExIconCursor.GetWidth : Integer |
|
||
| |
|
||
| Returns the current image's width in pixels |
|
||
*----------------------------------------------------------------------------*)
|
||
function TExIconCursor.GetWidth: Integer;
|
||
begin
|
||
result := FImages [fCurrentImage].FWidth;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.HandleNeeded |
|
||
| |
|
||
| Ensure that an HICON handle exists for the current image. Don't use this |
|
||
| unless strictly necessary. It may bugger up in NT4 |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.HandleNeeded;
|
||
begin
|
||
FImages [FCurrentImage].HandleNeeded;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.ImageNeeded |
|
||
| |
|
||
| Ensure that a memory image exists for the current image. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.ImageNeeded;
|
||
begin
|
||
with FImages [FCurrentImage] do ImageNeeded;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.LoadFromClipboardFormat |
|
||
| |
|
||
| Ensure that a memory image exists for the current image. Affects just the |
|
||
| current image. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.LoadFromClipboardFormat(AFormat: Word;
|
||
AData: THandle; APalette: HPALETTE);
|
||
var
|
||
Info : PBItmapInfo;
|
||
image : TExIconImage;
|
||
size : DWORD;
|
||
InfoHeaderSize, ImageSize, monoSize : DWORD;
|
||
mask : PByte;
|
||
begin
|
||
size := GlobalSize (AData);
|
||
if (size > 0) and (AFormat = CF_DIB) then
|
||
begin
|
||
|
||
image := TExIconImage.Create;
|
||
image.FMemoryImage := TMemoryStream.Create;
|
||
image.Reference;
|
||
|
||
try
|
||
info := PBitmapInfo (GlobalLock (AData));
|
||
try
|
||
image.FIsIcon := Images [FCurrentImage].FIsIcon;
|
||
|
||
image.FWidth := info^.bmiHeader.biWidth;
|
||
image.FHeight := info^.bmiHeader.biHeight;
|
||
image.FPixelFormat := GetBitmapInfoPixelFormat (info^.bmiHeader);
|
||
|
||
GetBitmapInfoSizes (info^.bmiHeader, InfoHeaderSize, ImageSize, False);
|
||
monoSize := image.Width * image.FHeight div 8;
|
||
|
||
if size = InfoHeaderSize + ImageSize + monoSize then
|
||
image.FMemoryImage.Write (info^, InfoHeaderSize + ImageSize + monoSize)
|
||
else
|
||
begin
|
||
image.FMemoryImage.Write (info^, InfoHeaderSize + ImageSize);
|
||
GetMem (mask, monoSize);
|
||
try
|
||
FillChar (mask^, monoSize, $00);
|
||
image.FMemoryImage.Write (mask^, monoSize)
|
||
finally
|
||
FreeMem (mask)
|
||
end
|
||
end;
|
||
PBitmapInfo (image.FMemoryImage.Memory)^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2;
|
||
finally
|
||
GlobalUnlock (AData)
|
||
end
|
||
except
|
||
image.Release;
|
||
raise
|
||
end;
|
||
|
||
FImages [FCurrentImage].Release;
|
||
FImages [FCurrentImage] := image
|
||
end
|
||
end;
|
||
|
||
procedure TExIconCursor.LoadFromResourceId(Instance: THandle;
|
||
ResID : Integer);
|
||
var
|
||
Stream: TCustomMemoryStream;
|
||
begin
|
||
Stream := TResourceStream.CreateFromID(Instance, ResID, RT_ICON);
|
||
try
|
||
ReadIcon(Instance, Stream, Stream.Size);
|
||
finally
|
||
Stream.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TExIconCursor.LoadFromResourceName(Instance: THandle;
|
||
const resName: string);
|
||
var
|
||
Stream: TCustomMemoryStream;
|
||
begin
|
||
Stream := TResourceStream.Create(Instance, ResName, RT_GROUP_ICON);
|
||
try
|
||
ReadIcon(Instance, Stream, Stream.Size);
|
||
finally
|
||
Stream.Free;
|
||
end;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.LoadFromStream |
|
||
| |
|
||
| Load all images from a stream |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.LoadFromStream(Stream: TStream);
|
||
var
|
||
hdr : TIconHeader;
|
||
dirEntry : array of TIconDirEntry;
|
||
i : Integer;
|
||
p : PBitmapInfoHeader;
|
||
begin
|
||
Stream.Read (hdr, SizeOf (hdr));
|
||
|
||
if (self is TExIcon) <> (hdr.wType = 1) then
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
|
||
ReleaseImages; // Get rid of existing images
|
||
|
||
SetLength (fImages, hdr.wCount);
|
||
SetLength (dirEntry, hdr.wCount);
|
||
|
||
// Create and initialize the ExIconImage classes and read
|
||
// the dirEntry structures from the stream.
|
||
|
||
for i := 0 to hdr.wCount - 1 do
|
||
begin
|
||
fImages [i] := TExIconImage.Create;
|
||
fImages [i].FIsIcon := self is TExIcon;
|
||
fImages [i].FMemoryImage := TMemoryStream.Create;
|
||
fImages [i].Reference;
|
||
|
||
Stream.Read (dirEntry [i], SizeOf (TIconDirEntry));
|
||
fImages [i].FWidth := dirEntry [i].bWidth;
|
||
fImages [i].FHeight := dirEntry [i].bHeight;
|
||
end;
|
||
|
||
// Read the icon images into their Memory streams
|
||
for i := 0 to hdr.wCount - 1 do
|
||
begin
|
||
|
||
stream.Seek (dirEntry [i].dwImageOffset, soFromBeginning);
|
||
|
||
fImages [i].FMemoryImage.CopyFrom (stream, dirEntry [i].dwBytesInRes);
|
||
|
||
p := FImages [i].GetBitmapInfoHeader;
|
||
p^.biSizeImage := 0;
|
||
|
||
fImages [i].FPixelFormat := GetBitmapInfoPixelFormat (p^);
|
||
end;
|
||
|
||
FCurrentImage := 0;
|
||
Changed(Self);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.PaletteNeeded |
|
||
| |
|
||
| The palette is needed for the current image |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.PaletteNeeded;
|
||
begin
|
||
FImages [FCurrentImage].PaletteNeeded;
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.ReleaseImages |
|
||
| |
|
||
| Release images for the icon. Internal use only - you must set up at least |
|
||
| one new image after calling it. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.ReadIcon(instance : THandle; stream: TCustomMemoryStream;
|
||
Size: Integer);
|
||
var
|
||
hdr : TIconHeader;
|
||
resDir : TResourceDirectory;
|
||
i : Integer;
|
||
strm1 : TCustomMemoryStream;
|
||
p : PBitmapInfoHEader;
|
||
begin
|
||
stream.read (hdr, SizeOf (hdr));
|
||
|
||
if (self is TExIcon) <> (hdr.wType = 1) then
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
|
||
ReleaseImages; // Get rid of existing images
|
||
|
||
SetLength (fImages, hdr.wCount);
|
||
|
||
for i := 0 to hdr.wCount - 1 do
|
||
begin
|
||
stream.read (resDir, SizeOf (resDir));
|
||
|
||
strm1 := TResourceStream.CreateFromID (Instance, resDir.wNameOrdinal, RT_ICON);
|
||
try
|
||
fImages [i] := TExIconImage.Create;
|
||
fImages [i].FIsIcon := self is TExIcon;
|
||
fImages [i].FMemoryImage := TMemoryStream.Create;
|
||
fImages [i].Reference;
|
||
|
||
if Self is TExIcon then
|
||
begin
|
||
fImages [i].FWidth := resDir.details.iconWidth;
|
||
fImages [i].FHeight := resDir.details.iconHeight
|
||
end
|
||
else
|
||
begin
|
||
fImages [i].FWidth := resDir.details.cursorWidth;
|
||
fImages [i].FHeight := resDir.details.cursorHeight
|
||
end;
|
||
|
||
fImages [i].FMemoryImage.CopyFrom (strm1, 0);
|
||
p := FImages [i].GetBitmapInfoHeader;
|
||
p^.biSizeImage := 0;
|
||
|
||
fImages [i].FPixelFormat := GetBitmapInfoPixelFormat (p^);
|
||
finally
|
||
strm1.Free
|
||
end
|
||
end;
|
||
|
||
FCurrentImage := 0;
|
||
Changed(Self);
|
||
end;
|
||
|
||
function TExIconCursor.ReleaseHandle: HICON;
|
||
begin
|
||
HandleNeeded;
|
||
if FImages [fCurrentImage].RefCount > 1 then
|
||
Result := CopyIcon (FImages [fCurrentImage].FHandle) else
|
||
begin
|
||
Result := FImages [fCurrentImage].FHandle;
|
||
FImages [fCurrentImage].fHandle := 0
|
||
end
|
||
end;
|
||
|
||
procedure TExIconCursor.ReleaseImages;
|
||
var
|
||
i : Integer;
|
||
begin
|
||
for i := 0 to Length (fImages) - 1 do
|
||
fImages [i].Release;
|
||
|
||
SetLength (fImages, 0)
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExIconCursor.SaveImageToFile
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExIconCursor.SaveImageToFile(const FileName: string);
|
||
// Save current image to 'ico' file
|
||
var
|
||
hdr : TIconHeader;
|
||
dirEntry : TIconDirEntry;
|
||
image : TExIconImage;
|
||
dirSize : Integer;
|
||
stream : TStream;
|
||
begin
|
||
hdr.wReserved := 0;
|
||
if not (self is TExCursor) then
|
||
hdr.wType := 1
|
||
else
|
||
hdr.wType := 2;
|
||
hdr.wCount := 1;
|
||
|
||
stream := TFileStream.Create (FileName, fmCreate);
|
||
try
|
||
Stream.Write (hdr, SizeOf (hdr));
|
||
dirSize := sizeof (dirEntry) + sizeof (hdr);
|
||
|
||
ImageNeeded;
|
||
image := Images [CurrentImage];
|
||
|
||
FillChar (dirEntry, SizeOf (dirEntry), 0);
|
||
|
||
dirEntry.bWidth := image.Width;
|
||
dirEntry.bHeight := image.Height;
|
||
|
||
case image.PixelFormat of
|
||
pf1Bit : begin dirEntry.bColorCount := 2; dirEntry.wBitCount := 0; end;
|
||
pf4Bit : begin dirEntry.bColorCount := 16; dirEntry.wBitCount := 0; end;
|
||
pf8Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 8; end;
|
||
pf16Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 16; end;
|
||
pf24Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitcount := 24; end;
|
||
pf32Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 32; end;
|
||
else
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
end;
|
||
|
||
if hdr.wType = 2 then
|
||
begin
|
||
dirEntry.wPlanes := LOWORD (TExCursor (Self).Hotspot);
|
||
dirEntry.wBitCount := HIWORD (TExCursor (Self).Hotspot)
|
||
end
|
||
else
|
||
dirEntry.wPlanes := 1;
|
||
dirEntry.dwBytesInRes := image.FMemoryImage.Size;
|
||
if hdr.wType = 2 then
|
||
begin
|
||
image.FMemoryImage.Seek (SizeOf (DWORD), soFromBeginning);
|
||
Dec (dirEntry.dwBytesInRes, SizeOf (DWORD))
|
||
end
|
||
else
|
||
image.FMemoryImage.Seek (0, soFromBeginning);
|
||
|
||
dirEntry.dwImageOffset := dirSize;
|
||
Stream.Write (dirEntry, SizeOf (dirEntry));
|
||
Stream.CopyFrom (image.FMemoryImage, image.FMemoryImage.Size - image.FMemoryImage.Position);
|
||
|
||
finally
|
||
stream.Free
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.SaveToClipboardFormat |
|
||
| |
|
||
| Saves the image on the clipboard as a DDB |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.SaveToClipboardFormat(var AFormat: Word;
|
||
var AData: THandle; var APalette: HPALETTE);
|
||
var
|
||
info : PBitmapInfo;
|
||
InfoHeaderSize, ImageSize, monoSize : DWORD;
|
||
buf : PChar;
|
||
begin
|
||
AFormat := CF_DIB;
|
||
ImageNeeded;
|
||
info := Images [fCurrentImage].GetBitmapInfo;
|
||
info^.bmiHeader.biHeight := info^.bmiHeader.biHeight div 2;
|
||
try
|
||
GetBitmapInfoSizes (info^.bmiHeader, InfoHeaderSize, ImageSize, False);
|
||
monoSize := Width * Height div 8;
|
||
|
||
AData := GlobalAlloc (GMEM_DDESHARE, InfoHeaderSize + ImageSize + monoSize);
|
||
buf := GlobalLock (AData);
|
||
try
|
||
Move (info^, buf^, InfoHeaderSize + ImageSize + monoSize);
|
||
finally
|
||
GlobalUnlock (AData)
|
||
end;
|
||
|
||
APalette := 0; // Don't need the palette, cause we've copied the DIB
|
||
finally
|
||
info^.bmiHeader.biHeight := info^.bmiHeader.biHeight * 2
|
||
end;
|
||
end;
|
||
|
||
procedure TExIconCursor.SaveToStream(Stream: TStream);
|
||
var
|
||
hdr : TIconHeader;
|
||
dirEntry : TIconDirEntry;
|
||
image : TExIconImage;
|
||
i, dirSize, offset : Integer;
|
||
oldCurrentImage : Integer;
|
||
begin
|
||
hdr.wReserved := 0;
|
||
if not (self is TExCursor) then
|
||
hdr.wType := 1
|
||
else
|
||
hdr.wType := 2;
|
||
hdr.wCount := ImageCount;
|
||
|
||
Stream.Write (hdr, SizeOf (hdr));
|
||
dirSize := ImageCount * sizeof (dirEntry) + sizeof (hdr);
|
||
|
||
oldCurrentImage := FCurrentImage;
|
||
try
|
||
offset := 0;
|
||
for i := 0 to ImageCount - 1 do
|
||
begin
|
||
FCurrentImage := i;
|
||
ImageNeeded;
|
||
image := Images [i];
|
||
|
||
FillChar (dirEntry, SizeOf (dirEntry), 0);
|
||
|
||
dirEntry.bWidth := image.Width;
|
||
dirEntry.bHeight := image.Height;
|
||
|
||
case image.PixelFormat of
|
||
pf1Bit : begin dirEntry.bColorCount := 2; dirEntry.wBitCount := 0; end;
|
||
pf4Bit : begin dirEntry.bColorCount := 16; dirEntry.wBitCount := 0; end;
|
||
pf8Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 8; end;
|
||
pf16Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 16; end;
|
||
pf24Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitcount := 24; end;
|
||
pf32Bit : begin dirEntry.bColorCount := 0; dirEntry.wBitCount := 32; end;
|
||
else
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
end;
|
||
|
||
dirEntry.wPlanes := 1;
|
||
dirEntry.dwBytesInRes := image.FMemoryImage.Size;
|
||
dirEntry.dwImageOffset := dirSize + offset;
|
||
|
||
Stream.Write (dirEntry, SizeOf (dirEntry));
|
||
Inc (offset, dirEntry.dwBytesInRes);
|
||
end
|
||
finally
|
||
FCurrentImage := oldCurrentImage
|
||
end;
|
||
|
||
for i := 0 to ImageCount - 1 do
|
||
images [i].FMemoryImage.SaveToStream (Stream);
|
||
end;
|
||
|
||
procedure TExIconCursor.SetCurrentImage(const Value: Integer);
|
||
begin
|
||
if fCurrentImage <> value then
|
||
begin
|
||
fCurrentImage := Value;
|
||
Changed (self)
|
||
end
|
||
end;
|
||
|
||
procedure TExIconCursor.SetHandle(const Value: HICON);
|
||
var
|
||
iconInfo : TIconInfo;
|
||
BI : TBitmapInfoHeader;
|
||
image : TExIconImage;
|
||
begin
|
||
if GetIconInfo (value, iconInfo) then
|
||
try
|
||
image := TExIconImage.Create;
|
||
try
|
||
InitializeBitmapInfoHeader (iconInfo.hbmColor, BI, pfDevice);
|
||
image.FIsIcon := self is TExIcon;
|
||
image.FWidth := BI.biWidth;
|
||
image.FHeight := BI.biHeight;
|
||
image.FPixelFormat := GetBitmapInfoPixelFormat (BI);
|
||
except
|
||
image.Free;
|
||
raise
|
||
end;
|
||
|
||
image.FHandle := Value;
|
||
|
||
Images [fCurrentImage].Release;
|
||
fImages [fCurrentImage] := image;
|
||
image.Reference;
|
||
Changed(Self)
|
||
finally
|
||
DeleteObject (iconInfo.hbmMask);
|
||
DeleteObject (iconInfo.hbmColor)
|
||
end
|
||
else
|
||
RaiseLastOSError;
|
||
end;
|
||
|
||
procedure TExIconCursor.SetHeight(Value: Integer);
|
||
begin
|
||
if Value = Height then Exit;
|
||
Images [FCurrentImage].FHeight := Value;
|
||
AssignFromGraphic (Self);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.SetPalette |
|
||
| |
|
||
| Modify the icon so it uses a new palette (with maybe a differnt color |
|
||
| count, hence pixel format... |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.SetPalette(Value: HPALETTE);
|
||
var
|
||
colorCount : DWORD;
|
||
newPixelFormat : TPixelFormat;
|
||
begin
|
||
newPixelFormat := pfDevice;
|
||
colorCount := 0;
|
||
if GetObject (Value, sizeof (colorCount), @colorCount) = 0 then
|
||
RaiseLastOSError;
|
||
|
||
case colorCount of
|
||
1..2 : newPixelFormat := pf1Bit;
|
||
3..16 : newPixelFormat := pf4Bit;
|
||
17..256 : newPixelFormat := pf8Bit;
|
||
end;
|
||
|
||
if FImages [FCurrentImage].FPalette <> 0 then
|
||
DeleteObject (FImages [FCurrentImage].FPalette);
|
||
|
||
if newPixelFormat <> pfDevice then
|
||
begin
|
||
FImages [FCurrentImage].FPixelFormat := newPixelFormat;
|
||
|
||
FImages [FCurrentImage].FPalette := CopyPalette (Value);
|
||
FImages [FCurrentImage].FGotPalette := FImages [FCurrentImage].FPalette <> 0;
|
||
AssignFromGraphic (Self);
|
||
end
|
||
else
|
||
begin
|
||
FImages [FCurrentImage].FPalette := 0;
|
||
FImages [FCurrentImage].FGotPalette := True
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------------*
|
||
| procedure TExIconCursor.SetPixelFormat |
|
||
| |
|
||
| Modify the icon so it uses a new pixel format. If this pixel format has |
|
||
| <= 256 colours, apply an appropriate palette. Could modify this to use |
|
||
| sophisticated color reduction, but at the moment it uses the 'default' |
|
||
| 16 color palete, and the 'netscape' 256 color one. |
|
||
*----------------------------------------------------------------------------*)
|
||
procedure TExIconCursor.SetPixelFormat(const Value: TPixelFormat);
|
||
var
|
||
newPalette : HPALETTE;
|
||
begin
|
||
if value = PixelFormat then Exit;
|
||
|
||
case value of
|
||
pf1Bit : newPalette := SystemPalette2;
|
||
pf4Bit : newPalette := SystemPalette16;
|
||
pf8Bit : newPalette := SystemPalette256;
|
||
else
|
||
newPalette := 0
|
||
end;
|
||
|
||
FImages [FCurrentImage].FPixelFormat := Value;
|
||
|
||
if FImages [FCurrentImage].FPalette <> 0 then
|
||
DeleteObject (FImages [FCurrentImage].FPalette);
|
||
|
||
if newPalette <> 0 then
|
||
begin
|
||
FImages [FCurrentImage].FPalette := CopyPalette (newPalette);
|
||
FImages [FCurrentImage].FGotPalette := FImages [FCurrentImage].FPalette <> 0;
|
||
end
|
||
else
|
||
begin
|
||
FImages [FCurrentImage].FPalette := 0;
|
||
FImages [FCurrentImage].FGotPalette := True
|
||
end;
|
||
|
||
AssignFromGraphic (self)
|
||
end;
|
||
|
||
procedure TExIconCursor.SetWidth (Value: Integer);
|
||
begin
|
||
if Value = Width then Exit;
|
||
|
||
Images [FCurrentImage].FWidth := Value;
|
||
AssignFromGraphic (Self);
|
||
end;
|
||
|
||
{ TExIconImage }
|
||
|
||
destructor TExIconImage.Destroy;
|
||
begin
|
||
FMemoryImage.Free;
|
||
inherited // Which calls FreeHandle if necessary
|
||
end;
|
||
|
||
procedure TExIconImage.FreeHandle;
|
||
begin
|
||
if FHandle <> 0 then
|
||
DestroyIcon(FHandle);
|
||
|
||
if FPalette <> 0 then
|
||
DeleteObject (FPalette);
|
||
FGotPalette := False;
|
||
FPalette := 0;
|
||
FHandle := 0;
|
||
end;
|
||
|
||
function TExIconImage.GetBitmapInfo: PBitmapInfo;
|
||
begin
|
||
if Assigned (FMemoryImage) then
|
||
if FIsIcon then
|
||
result := PBitmapInfo (FMemoryImage.Memory)
|
||
else
|
||
result := PBitmapInfo (PChar (FMemoryImage.Memory) + sizeof (DWORD))
|
||
else
|
||
result := Nil
|
||
end;
|
||
|
||
function TExIconImage.GetBitmapInfoHeader: PBitmapInfoHeader;
|
||
begin
|
||
result := PBitmapInfoHeader (GetBitmapInfo)
|
||
end;
|
||
|
||
function TExIconImage.GetMemoryImage: TCustomMemoryStream;
|
||
begin
|
||
ImageNeeded;
|
||
result := FMemoryImage
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExIconImage.HandleNeeded |
|
||
| |
|
||
| In general, call this as little as possible. I don't call it any- |
|
||
| where in this code - I draw the bitmaps directly, rather than using |
|
||
| DrawIconEx, etc. |
|
||
| |
|
||
| CreateIconFromResourceEx is very unreliable with icons > 16 colours |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExIconImage.HandleNeeded;
|
||
var
|
||
info : PBitmapInfoHeader;
|
||
buff : PByte;
|
||
begin
|
||
if Handle <> 0 then exit;
|
||
if FMemoryImage = Nil then exit;
|
||
|
||
if fPalette <> 0 then
|
||
begin
|
||
DeleteObject (fPalette);
|
||
fPalette := 0;
|
||
fGotPalette := False;
|
||
end;
|
||
|
||
if FMemoryImage.Size > sizeof (TBitmapInfoHeader) + 4 then
|
||
begin
|
||
info := GetBitmapInfoHeader;
|
||
|
||
// Aaaagh. I don't believe I'm doing this. For some reason you cant use 'FMemoryImage.Memory'
|
||
// directly in CreateIconFromResourceEx. You have to copy it to a (GMEM_MOVEABLE) buffer first.
|
||
//
|
||
// And they call NT an operating system!
|
||
|
||
GetMem (buff, FMemoryImage.Size);
|
||
try
|
||
FMemoryImage.Seek (0, soFromBeginning);
|
||
Move (FMemoryImage.Memory^, buff^, FMemoryImage.Size);
|
||
|
||
FHandle := CreateIconFromResourceEx (buff, FMemoryImage.Size, FisIcon, $00030000, info^.biWidth, info^.biHeight div 2, LR_DEFAULTCOLOR);
|
||
finally
|
||
FreeMem (Buff)
|
||
end;
|
||
|
||
if FHandle = 0 then raise
|
||
EInvalidGraphic.Create (rstInvalidIcon);
|
||
|
||
FWidth := info^.biWidth;
|
||
FHeight := info^.biHeight div 2;
|
||
FPixelFormat := GetBitmapInfoPixelFormat (info^);
|
||
|
||
if info^.biBitCount <= 8 then
|
||
FPalette := CreateDIBPalette (PBitmapInfo (info)^);
|
||
|
||
fGotPalette := FPalette <> 0;
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExIconImage.ImageNeeded
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExIconImage.ImageNeeded;
|
||
var
|
||
Image: TMemoryStream;
|
||
IconInfo: TIconInfo;
|
||
MonoInfoSize, ColorInfoSize: DWORD;
|
||
MonoBitsSize, ColorBitsSize: DWORD;
|
||
MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
|
||
begin
|
||
if FMemoryImage <> nil then Exit;
|
||
if FHandle = 0 then
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
|
||
Image := TMemoryStream.Create;
|
||
try
|
||
GetIconInfo(Handle, IconInfo);
|
||
try
|
||
InternalGetDIBSizes(IconInfo.hbmMask, MonoInfoSize, MonoBitsSize, pf1Bit);
|
||
if IconInfo.hbmColor <> 0 then
|
||
InternalGetDIBSizes(IconInfo.hbmColor, ColorInfoSize, ColorBitsSize, PixelFormat);
|
||
|
||
MonoInfo := nil;
|
||
MonoBits := nil;
|
||
ColorInfo := nil;
|
||
ColorBits := nil;
|
||
try
|
||
MonoInfo := AllocMem(MonoInfoSize);
|
||
MonoBits := AllocMem(MonoBitsSize);
|
||
InternalGetDIB(IconInfo.hbmMask, 0, PBitmapInfo (MonoInfo), MonoBits^, pf1Bit);
|
||
|
||
if IconInfo.hbmColor <> 0 then
|
||
begin
|
||
ColorInfo := AllocMem(ColorInfoSize);
|
||
ColorBits := AllocMem(ColorBitsSize);
|
||
|
||
InternalGetDIB(IconInfo.hbmColor, FPalette, PBitmapInfo (ColorInfo), ColorBits^, PixelFormat);
|
||
with PBitmapInfoHeader(ColorInfo)^ do
|
||
Inc(biHeight, biHeight); { color height includes mono bits }
|
||
end;
|
||
|
||
if (not FIsIcon) then
|
||
begin
|
||
Image.Write (IconInfo.xHotspot, SizeOf (iconInfo.xHotspot));
|
||
Image.Write (IconInfo.yHotspot, SizeOf (iconInfo.yHotspot))
|
||
end;
|
||
|
||
if IconInfo.hbmColor <> 0 then
|
||
begin
|
||
Image.Write(ColorInfo^, ColorInfoSize);
|
||
Image.Write(ColorBits^, ColorBitsSize)
|
||
end
|
||
else
|
||
Image.Write(MonoInfo^, MonoInfoSize);
|
||
|
||
Image.Write(MonoBits^, MonoBitsSize);
|
||
finally
|
||
FreeMem(ColorInfo, ColorInfoSize);
|
||
FreeMem(ColorBits, ColorBitsSize);
|
||
FreeMem(MonoInfo, MonoInfoSize);
|
||
FreeMem(MonoBits, MonoBitsSize);
|
||
end;
|
||
finally
|
||
if IconInfo.hbmColor <> 0 then
|
||
DeleteObject(IconInfo.hbmColor);
|
||
DeleteObject(IconInfo.hbmMask);
|
||
end
|
||
except
|
||
Image.Free;
|
||
raise;
|
||
end;
|
||
FMemoryImage := Image
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExIconImage.PaletteNeeded
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExIconImage.PaletteNeeded;
|
||
var
|
||
info : PBitmapInfoHeader;
|
||
begin
|
||
if fGotPalette then Exit;
|
||
if fMemoryImage = Nil then Exit;
|
||
|
||
info := GetBitmapInfoHeader;
|
||
|
||
if fPixelFormat in [pf1Bit..pf8Bit] then
|
||
FPalette := CreateDIBPalette (PBitmapInfo (info)^);
|
||
|
||
fGotPalette := True;
|
||
end;
|
||
|
||
{ TExCursor }
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExCursor.Create
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
constructor TExCursor.Create;
|
||
begin
|
||
inherited;
|
||
|
||
with FImages [0] do
|
||
begin
|
||
fWidth := GetSystemMetrics (SM_CXCURSOR);
|
||
fHeight := GetSystemMetrics (SM_CYCURSOR);
|
||
fPixelFormat := pf1Bit
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExCursor.GetHotspot
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
function TExCursor.GetHotspot: DWORD;
|
||
begin
|
||
ImageNeeded;
|
||
Result := PDWORD (Images [fCurrentImage].FMemoryImage.Memory)^
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExCursor.SetHotspot
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExCursor.LoadFromFile(const FileName: string);
|
||
var
|
||
hdr : TIconHeader;
|
||
dirEntry : array of TIconDirEntry;
|
||
i : Integer;
|
||
p : PBitmapInfoHeader;
|
||
stream : TFileStream;
|
||
hotspot : DWORD;
|
||
begin
|
||
stream := TFileStream.Create (FileName, fmOpenRead or fmShareDenyWrite);
|
||
try
|
||
Stream.Read (hdr, SizeOf (hdr));
|
||
|
||
if hdr.wType <> 2 then
|
||
raise EInvalidGraphic.Create (rstInvalidCursor);
|
||
|
||
ReleaseImages; // Get rid of existing images
|
||
|
||
SetLength (fImages, hdr.wCount);
|
||
SetLength (dirEntry, hdr.wCount);
|
||
|
||
// Create and initialize the ExIconImage classes and read
|
||
// the dirEntry structures from the stream.
|
||
|
||
for i := 0 to hdr.wCount - 1 do
|
||
begin
|
||
fImages [i] := TExIconImage.Create;
|
||
fImages [i].FIsIcon := False;
|
||
fImages [i].FMemoryImage := TMemoryStream.Create;
|
||
fImages [i].Reference;
|
||
|
||
Stream.Read (dirEntry [i], SizeOf (TIconDirEntry));
|
||
fImages [i].FWidth := dirEntry [i].bWidth;
|
||
fImages [i].FHeight := dirEntry [i].bHeight;
|
||
end;
|
||
|
||
// Read the icon images into their Memory streams
|
||
for i := 0 to hdr.wCount - 1 do
|
||
begin
|
||
hotspot := MAKELONG (dirEntry [i].wPlanes, dirEntry [i].wBitCount);
|
||
|
||
stream.Seek (dirEntry [i].dwImageOffset, soFromBeginning);
|
||
|
||
fImages [i].FMemoryImage.Write (hotspot, SizeOf (hotspot));
|
||
fImages [i].FMemoryImage.CopyFrom (stream, dirEntry [i].dwBytesInRes);
|
||
|
||
p := FImages [i].GetBitmapInfoHeader;
|
||
p^.biSizeImage := 0;
|
||
|
||
fImages [i].FPixelFormat := GetBitmapInfoPixelFormat (p^);
|
||
end;
|
||
|
||
FCurrentImage := 0;
|
||
Changed(Self)
|
||
finally
|
||
stream.Free
|
||
end
|
||
end;
|
||
|
||
procedure TExCursor.SaveToFile(const FileName: string);
|
||
var
|
||
hdr : TIconHeader;
|
||
dirEntry : TIconDirEntry;
|
||
image : TExIconImage;
|
||
i, dirSize, offset : Integer;
|
||
oldCurrentImage : Integer;
|
||
stream : TFileStream;
|
||
begin
|
||
stream := TFileStream.Create (FileName, fmCreate);
|
||
try
|
||
hdr.wReserved := 0;
|
||
hdr.wType := 2;
|
||
hdr.wCount := ImageCount;
|
||
|
||
Stream.Write (hdr, SizeOf (hdr));
|
||
dirSize := ImageCount * sizeof (dirEntry) + sizeof (hdr);
|
||
|
||
oldCurrentImage := FCurrentImage;
|
||
try
|
||
offset := 0;
|
||
for i := 0 to ImageCount - 1 do
|
||
begin
|
||
FCurrentImage := i;
|
||
ImageNeeded;
|
||
image := Images [i];
|
||
|
||
FillChar (dirEntry, SizeOf (dirEntry), 0);
|
||
|
||
dirEntry.bWidth := image.Width;
|
||
dirEntry.bHeight := image.Height;
|
||
|
||
case image.PixelFormat of
|
||
pf1Bit : dirEntry.bColorCount := 2;
|
||
pf4Bit : dirEntry.bColorCount := 16;
|
||
pf8Bit : dirEntry.bColorCount := 0;
|
||
pf16Bit : dirEntry.bColorCount := 0;
|
||
pf24Bit : dirEntry.bColorCount := 0;
|
||
pf32Bit : dirEntry.bColorCount := 0;
|
||
else
|
||
raise EInvalidGraphic.Create (rstInvalidIcon);
|
||
end;
|
||
|
||
dirEntry.wPlanes := LOWORD (Hotspot);
|
||
dirEntry.wBitCount := HIWORD (Hotspot);
|
||
|
||
dirEntry.dwBytesInRes := image.FMemoryImage.Size - SizeOf (DWORD);
|
||
dirEntry.dwImageOffset := dirSize + offset;
|
||
|
||
Stream.Write (dirEntry, SizeOf (dirEntry));
|
||
Inc (offset, dirEntry.dwBytesInRes);
|
||
end
|
||
finally
|
||
FCurrentImage := oldCurrentImage
|
||
end;
|
||
|
||
for i := 0 to ImageCount - 1 do
|
||
begin
|
||
fImages [i].FMemoryImage.Seek (SizeOf (DWORD), soFromBeginning);
|
||
Stream.CopyFrom (images [i].FMemoryImage, images [i].FMemoryImage.Size - images [i].fMemoryImage.Position);
|
||
end
|
||
finally
|
||
stream.Free
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExCursor.SetHotspot |
|
||
| |
|
||
| Set the cursor's hotspot |
|
||
*----------------------------------------------------------------------*)
|
||
procedure TExCursor.SetHotspot(const Value: DWORD);
|
||
begin
|
||
ImageNeeded;
|
||
PDWORD (images [fCurrentImage].fMemoryImage.memory)^ := Value;
|
||
end;
|
||
|
||
{ TExIcon }
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| TExIcon.Create
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
constructor TExIcon.Create;
|
||
begin
|
||
inherited;
|
||
with FImages [0] do
|
||
begin
|
||
fWidth := GetSystemMetrics (SM_CXICON);
|
||
fHeight := GetSystemMetrics (SM_CYICON);
|
||
fPixelFormat := pf4Bit
|
||
end
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| WebPalette
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
function WebPalette: HPalette;
|
||
type
|
||
TLogWebPalette = packed record
|
||
palVersion : word;
|
||
palNumEntries : word;
|
||
PalEntries : array [0..5,0..5,0..5] of TPaletteEntry;
|
||
MonoEntries : array [0..23] of TPaletteEntry;
|
||
StdEntries : array [0..15] of TPaletteEntry;
|
||
end;
|
||
var
|
||
r, g, b : byte;
|
||
LogWebPalette : TLogWebPalette;
|
||
LogPalette : TLogpalette absolute LogWebPalette; // Stupid typecast
|
||
begin
|
||
with LogWebPalette do
|
||
begin
|
||
GetPaletteEntries (SystemPalette16, 0, 16, StdEntries);
|
||
palVersion:= $0300;
|
||
palNumEntries:= 256;
|
||
|
||
g := 10;
|
||
for r := 0 to 23 do
|
||
begin
|
||
MonoEntries [r].peRed := g;
|
||
MonoEntries [r].peGreen := g;
|
||
MonoEntries [r].peBlue := g;
|
||
MonoEntries [r].peFlags := 0;
|
||
Inc (g, 10)
|
||
end;
|
||
|
||
for r:=0 to 5 do
|
||
for g:=0 to 5 do
|
||
for b:=0 to 5 do
|
||
begin
|
||
with PalEntries[r,g,b] do
|
||
begin
|
||
peRed := 51 * r;
|
||
peGreen := 51 * g;
|
||
peBlue := 51 * b;
|
||
peFlags := 0;
|
||
end;
|
||
end;
|
||
end;
|
||
Result := CreatePalette(Logpalette);
|
||
end;
|
||
|
||
(*----------------------------------------------------------------------*
|
||
| Create2ColorPalette
|
||
| |
|
||
*----------------------------------------------------------------------*)
|
||
function Create2ColorPalette : HPALETTE;
|
||
const
|
||
palColors2 : array [0..1] of TColor = ($000000, $ffffff);
|
||
var
|
||
logPalette : PLogPalette;
|
||
i, c : Integer;
|
||
|
||
begin
|
||
GetMem (logPalette, sizeof (logPalette) + 2 * sizeof (PALETTEENTRY));
|
||
|
||
try
|
||
logPalette^.palVersion := $300;
|
||
logPalette^.palNumEntries := 2;
|
||
{$R-}
|
||
for i := 0 to 1 do
|
||
with logPalette^.palPalEntry [i] do
|
||
begin
|
||
c := palColors2 [i];
|
||
|
||
peRed := c and $ff;
|
||
peGreen := c shr 8 and $ff;
|
||
peBlue := c shr 16 and $ff
|
||
end;
|
||
{$R+}
|
||
result := CreatePalette (logPalette^);
|
||
finally
|
||
FreeMem (logPalette)
|
||
end
|
||
end;
|
||
|
||
initialization
|
||
SystemPalette256 := WebPalette;
|
||
SystemPalette2 := Create2ColorPalette;
|
||
finalization
|
||
DeleteObject (SystemPalette2);
|
||
DeleteObject (SystemPalette256);
|
||
end.
|