unitresourcegraphics.pas

East make Tray Icon in delphi

(*======================================================================*
 | unitResourceGraphics                                                 |
 |                                                                      |
 | Encapsulates graphics in resources (icon, cursor, bitmap)            |
 |                                                                      |
 | Version  Date        By    Description                               |
 | -------  ----------  ----  ------------------------------------------|
 | 1.0      05/01/2001  CPWW  Original                                  |
 *======================================================================*)

unit unitResourceGraphics;

interface

uses Windows, Classes, SysUtils, unitResourceDetails, graphics, unitExIcon, gifimage;

type

//------------------------------------------------------------------------
// Base class

  TGraphicsResourceDetails = class (TResourceDetails)
  protected
    function GetHeight: Integer; virtual; abstract;
    function GetPixelFormat: TPixelFormat; virtual; abstract;
    function GetWidth: Integer; virtual; abstract;
  public
    procedure GetImage (picture : TPicture); virtual; abstract;
    procedure SetImage (image : TPicture); virtual;

    property Width : Integer read GetWidth;
    property Height : Integer read GetHeight;
    property PixelFormat : TPixelFormat read GetPixelFormat;
  end;

  TGraphicsResourceDetailsClass = class of TGraphicsResourceDetails;

//------------------------------------------------------------------------
// Bitmap resource details class

  TBitmapResourceDetails = class (TGraphicsResourceDetails)
  protected
    function GetHeight: Integer; override;
    function GetPixelFormat: TPixelFormat; override;
    function GetWidth: Integer; override;
    procedure InitNew; override;
    procedure InternalGetImage (s : TStream; picture : TPicture);
    procedure InternalSetImage (s : TStream; image : TPicture);

  public
    class function GetBaseType : string; override;
    procedure GetImage (picture : TPicture); override;
    procedure SetImage (image : TPicture); override;
  end;

//------------------------------------------------------------------------
// DIB resource details class
//
// Same as RT_BITMAP resources, but they have a TBitmapFileHeader at the start
// of the resource, before the TBitmapInfoHeader.  See
// \program files\Microsoft Office\office\1033\outlibr.dll

  TDIBResourceDetails = class (TBitmapResourceDetails)
  protected
    class function SupportsData (Size : Integer; data : Pointer) : Boolean; override;
    procedure InitNew; override;
  public
    class function GetBaseType : string; override;
    procedure GetImage (picture : TPicture); override;
    procedure SetImage (image : TPicture); override;
  end;

  TIconCursorResourceDetails = class;

//------------------------------------------------------------------------
// Icon / Cursor group resource details class

  TIconCursorGroupResourceDetails = class (TResourceDetails)
  private
    fDeleting : Boolean;
    function GetResourceCount: Integer;
    function GetResourceDetails(idx: Integer): TIconCursorResourceDetails;
  protected
    procedure InitNew; override;
  public
    procedure GetImage (picture : TPicture);
    property ResourceCount : Integer read GetResourceCount;
    property ResourceDetails [idx : Integer] : TIconCursorResourceDetails read GetResourceDetails;
    function Contains (details : TIconCursorResourceDetails) : Boolean;
    procedure RemoveFromGroup (details : TIconCursorResourceDetails);
    procedure AddToGroup (details : TIconCursorResourceDetails);
    procedure LoadImage (const FileName : string);
    procedure BeforeDelete; override;
  end;

//------------------------------------------------------------------------
// Icon group resource details class

  TIconGroupResourceDetails = class (TIconCursorGroupResourceDetails)
  public
    class function GetBaseType : string; override;
  end;

//------------------------------------------------------------------------
// Cursor group resource details class

  TCursorGroupResourceDetails = class (TIconCursorGroupResourceDetails)
  public
    class function GetBaseType : string; override;
  end;

//------------------------------------------------------------------------
// Icon / Cursor resource details class

  TIconCursorResourceDetails = class (TGraphicsResourceDetails)
  protected
    function GetHeight: Integer; override;
    function GetPixelFormat: TPixelFormat; override;
    function GetWidth: Integer; override;
  protected
    procedure InitNew; override;
  public
    procedure BeforeDelete; override;
    procedure GetImage (picture : TPicture); override;
    procedure SetImage (image : TPicture); override;
    property Width : Integer read GetWidth;
    property Height : Integer read GetHeight;
    property PixelFormat : TPixelFormat read GetPixelFormat;
  end;

//------------------------------------------------------------------------
// Icon resource details class

  TIconResourceDetails = class (TIconCursorResourceDetails)
  public
    class function GetBaseType : string; override;
  end;

//------------------------------------------------------------------------
// Cursor resource details class

  TCursorResourceDetails = class (TIconCursorResourceDetails)
  protected
  public
    class function GetBaseType : string; override;
  end;

const
  DefaultIconCursorWidth : Integer = 32;
  DefaultIconCursorHeight : Integer = 32;
  DefaultIconCursorPixelFormat : TPixelFormat = pf4Bit;
  DefaultCursorHotspot : DWord = $00100010;

  DefaultBitmapWidth : Integer = 128;
  DefaultBitmapHeight : Integer = 96;
  DefaultBitmapPixelFormat : TPixelFormat = pf24Bit;

implementation

type

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;

resourcestring
  rstCursors = 'Cursors';
  rstIcons = 'Icons';

{ TBitmapResourceDetails }

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.GetBaseType                                   |
 *----------------------------------------------------------------------*)
class function TBitmapResourceDetails.GetBaseType: string;
begin
  result := IntToStr (Integer (RT_BITMAP));
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.GetHeight                                     |
 *----------------------------------------------------------------------*)
function TBitmapResourceDetails.GetHeight: Integer;
begin
  result := PBitmapInfoHeader (data.Memory)^.biHeight
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.GetImage                                      |
 *----------------------------------------------------------------------*)
procedure TBitmapResourceDetails.GetImage(picture: TPicture);
var
  s : TMemoryStream;
  hdr : TBitmapFileHeader;
begin
  s := TMemoryStream.Create;
  try
    hdr.bfType :=$4D42;         // TBitmap.LoadFromStream requires a bitmapfileheader
    hdr.bfSize := data.size;    // before the data...
    hdr.bfReserved1 := 0;
    hdr.bfReserved2 := 0;
    hdr.bfOffBits := sizeof (hdr);

    s.Write (hdr, sizeof (hdr));
    data.Seek (0, soFromBeginning);
    s.CopyFrom (data, data.size);

    InternalGetImage (s, picture)
  finally
    s.Free
  end
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.GetPixelFormat                                |
 *----------------------------------------------------------------------*)
function TBitmapResourceDetails.GetPixelFormat: TPixelFormat;
begin
  result := GetBitmapInfoPixelFormat (PBitmapInfoHeader (data.Memory)^);
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.GetWidth                                      |
 *----------------------------------------------------------------------*)
function TBitmapResourceDetails.GetWidth: Integer;
begin
  result := PBitmapInfoHeader (data.Memory)^.biWidth
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.SetImage                                      |
 *----------------------------------------------------------------------*)
procedure TBitmapResourceDetails.InitNew;
var
  bi : TBitmapInfoHeader;
  imageSize : DWORD;
  bits : PChar;
begin
  bi.biSize := SizeOf (bi);
  bi.biWidth := DefaultBitmapWidth;
  bi.biHeight := DefaultBitmapHeight;
  bi.biPlanes := 1;
  bi.biBitCount := GetPixelFormatBitCount (DefaultBitmapPixelFormat);
  bi.biCompression := BI_RGB;

  imageSize := BytesPerScanLine (DefaultBitmapWidth, bi.biBitCount, 32) * DefaultBitmapHeight;
  bi.biSizeImage := imageSize;

  bi.biXPelsPerMeter := 0;
  bi.biYPelsPerMeter := 0;

  bi.biClrUsed := 0;
  bi.biClrImportant := 0;

  data.Write (bi, SizeOf (bi));

  bits := AllocMem (ImageSize);
  try
    data.Write (bits^, ImageSize);
  finally
    ReallocMem (bits, 0)
  end
end;

procedure TBitmapResourceDetails.InternalGetImage(s : TStream; picture: TPicture);
var
  pHdr : PBitmapInfoHeader;
  pal : HPalette;
  colors : DWORD;
  hangOnToPalette : Boolean;
  newBmp : TBitmap;
begin
  s.Seek (0, soFromBeginning);
  picture.Bitmap.IgnorePalette := False;
  picture.Bitmap.LoadFromStream (s);

  pHdr := PBitmapInfoHeader (data.Memory);

                              // TBitmap makes all RLE encoded bitmaps into pfDevice
                              // ... that's not good enough for us!  At least
                              // select the correct pixel format, preserve their carefully set
                              // up palette, etc.
                              //
                              // But revisit this - we probably shouldn't call LoadFromStream
                              // at all if this is the case...
                              //
                              // You can get a couple of RLE bitmaps out of winhlp32.exe

  if PHdr^.biCompression in [BI_RLE4, BI_RLE8] then
  begin
    hangOnToPalette := False;
    if pHdr^.biBitCount in [1, 4, 8] then
    begin
      pal := picture.Bitmap.Palette;
      if pal <> 0 then
      begin
        colors := 0;
        GetObject (pal, SizeOf (colors), @Colors);

        if colors = 1 shl pHdr^.biBitCount then
        begin
          hangOnToPalette := True;

          newBmp := TBitmap.Create;
          try
            case pHdr^.biBitCount of
              1 : newBmp.PixelFormat := pf1Bit;
              4 : newBmp.PixelFormat := pf4Bit;
              8 : newBmp.PixelFormat := pf8Bit;
            end;

            newBmp.Width := Picture.Bitmap.Width;
            newBmp.Height := Picture.Bitmap.Height;
            newBmp.Palette := CopyPalette (pal);
            newBmp.Canvas.Draw (0, 0, picture.Bitmap);
            picture.Bitmap.Assign (newBmp);
          finally
            newBmp.Free
          end
        end
      end
    end;

    if not hangOnToPalette then
      case pHdr^.biBitCount of
        1 : picture.Bitmap.PixelFormat := pf1Bit;
        4 : picture.Bitmap.PixelFormat := pf4Bit;
        8 : picture.Bitmap.PixelFormat := pf8Bit;
        else
          picture.Bitmap.PixelFormat := pf24Bit
      end
  end
end;

(*----------------------------------------------------------------------*
 | TBitmapResourceDetails.InternalSetImage                              |
 |                                                                      |
 | Save image 'image' to stream 's' as a bitmap                         |
 |                                                                      |
 | Parameters:                                                          |
 |                                                                      |
 |   s : TStream           The stream to save to                        |
 |   image : TPicture      The image to save                            |
 *----------------------------------------------------------------------*)
procedure TBitmapResourceDetails.InternalSetImage(s: TStream; image: TPicture);
var
  bmp : TBitmap;
begin
  s.Size := 0;
  bmp := TBitmap.Create;
  try
    bmp.Assign (image.graphic);
    bmp.SaveToStream (s);
  finally
    bmp.Free;
  end
end;