unitexicon.pas

海盗远控1.23源代码

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                                               |
 |                                                                            |