qwincursors.pas

East make Tray Icon in delphi

{-------------------------------------------------------------------------------------------------}
{ TWinCursor                                                                                      }
{                                                                                                 }
{ Copyright (c) 2002, Matthias Thoma ([e-mail])                                                             }
{ All rights reserved.                                                                            }
{                                                                                                 }
{ Version 0.6                                                                                     }
{ Supported:     - Traditional cursors                                                            }
{ Not supported: - Multicolor cursors (as soon as QT3 is supported)                               }
{                - Animated cursors (maybe in feature)                                            }
{                                                                                                 }
{ Thanks to Christoph Federer for Beta testing.                                                   }
{                                                                                                 }
{ Permission is hereby granted, free of charge, to any person obtaining a copy of this software   }
{ and associated documentation files(the "Software"), to deal in the Software without restriction,}
{ including without limitation the rights to use, copy, modify, merge, publish, distribute,       }
{ sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is   }
{ furnished to do so, subject to the following conditions:                                        }
{                                                                                                 }
{ The above copyright notice and this permission notice shall be included in all copies or        }
{ substantial portions of the Software.                                                           }
{                                                                                                 }
{ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING   }
{ BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND      }
{ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,    }
{ DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,  }
{ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.         }
{-------------------------------------------------------------------------------------------------}

unit QWinCursors;
{$R-}

interface
uses
  Classes, SysUtils, Types,
  Qt, QGraphics, QTypes;

type
  TCurInvMode = (invBlack, invWhite, invTransparent);

type
  TWinCursor = class(TGraphic)
  private
    FHandle: QCursorH;
    FWidth: Integer;
    FHeight: Integer;
    FBytesPerRow: Word;
    FOwnsHandle: Boolean;
    FInvMode: TCurInvMode;
    FHotspot: TPoint;
    FCustomCursor: record
      Bits: array of Byte;
      Mask: array of Byte;
    end;
  protected
    procedure ConvertDIB(Stream: TStream);
    procedure CreateCursor;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure FreeCursor;
    function GetHotSpot: TPoint;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure HandleNeeded;
    procedure SetHeight(Value: Integer); override;
    procedure SetHotspot(const Value: TPoint); virtual;
    procedure SetWidth(Value: Integer); override;
  public
    property Handle: QCursorH read FHandle;
    property Height: Integer read FHeight;
    property Hotspot: TPoint read GetHotspot write SetHotspot;
    property InvMode: TCurInvMode read FInvMode write FInvMode;
    property Width: Integer read FWidth;

    constructor Create;  reintroduce; overload;
    constructor Create(AHandle: QCursorH); reintroduce; overload;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromMimeSource(MimeSource: TMimeSource); override;
    procedure LoadFromResourceName(Instance: Cardinal; ResourceName: string);
    procedure OwnHandle;
    procedure SaveToMimeSource(MimeSource: TClxMimeSource); override;
    procedure SaveToStream(Stream: TStream); override;

    function ReleaseHandle: QCursorH;
  end;

function LoadCursor(Instance: Cardinal; CursorName: string): QCursorH;
function LoadCursorFromFile(CursorFileName: string): QCursorH;

type
  EWinCursor = class(Exception);

implementation

resourcestring
  RsUnsupported = 'Unsupported or illegal format.';
  RsInvalidOperation = 'Invalid operation.';

type
   _CURSORDIRENTRY = packed record
     bWidth: Byte;
     bHeight: Byte;
     bColorCount: Byte;
     bReserved: Byte;
     wXHotspot: Word;
     wYHotspot: Word;
     lBytesInRes: DWORD;
     dwImageOffset: DWORD;
   end;

   TCURSORDIRENTRY = _CURSORDIRENTRY;
   PCURSORDIRENTRY = ^_CURSORDIRENTRY;

   _CURSORDIR =  packed record
    cdReserved: WORD;
    cdType: WORD;
    cdCount: WORD;
  end;

  TCURSORDIR = _CURSORDIR;
  PCURSORDIR = ^_CURSORDIR;

  TResCursorDir = packed record
     Width: Word;
     Height: Word;
     Planes: Word;
     BitCount: Word;
     BytesInRes: DWORD;
     IconCursorId: Word;
  end;

type
  TCustomCursor = record
      Bits: array of Byte;
      Mask: array of Byte;
    end;

type
  tagLocalHeader = packed record
     XHotSpot: Word;
     YHotSpot: Word;
     Reserved: Int64;
  end;

//=== TWinCursor =============================================================

constructor TWinCursor.Create;
begin
  inherited Create;

  FHandle := nil;
  FWidth := 0;
  FHeight := 0;
  FBytesPerRow := 0;
  FOwnsHandle := False;
  FInvMode := InvTransparent;
end;

constructor TWinCursor.Create(AHandle: QCursorH);
begin
  inherited Create;

  FHandle := AHandle;
  FOwnsHandle := False;
end;

destructor TWinCursor.Destroy;
begin
  if FOwnsHandle then
    FreeCursor;

  inherited Destroy;
end;

procedure TWinCursor.LoadFromResourceName(Instance: Cardinal; ResourceName: String);
var
  ResourceStream: TResourceStream;
  CURSORDIR: TCURSORDIR;
  ResDir: TResCursorDir;
  BmpInfo: TBITMAPINFOHEADER;
  localHeader: tagLocalHeader;
begin
  ResourceStream := TResourceStream.Create(Instance, ResourceName, PChar(12));

  try
    ResourceStream.ReadBuffer(CursorDir, SizeOf(TCursorDir));

    if (CursorDir.cdReserved <> 0) or (CursorDir.cdType <> 2) or (CursorDir.cdCount <> 1) then
      raise EWinCursor.Create(RsUnsupported);

    ResourceStream.ReadBuffer(ResDir, SizeOf(TResCursorDir));

    FWidth := ResDir.Width;
    FHeight := ResDir.Height div 2;
  finally
    ResourceStream.Free;
  end;

  ResourceStream := TResourceStream.CreateFromID(HInstance, ResDir.IconCursorId, PChar(1));
  try
    ResourceStream.Position := 0;
    ResourceStream.Read(LocalHeader, SizeOf(tagLocalHeader));

    FBytesPerRow := FWidth div 8;

    if (FWidth mod 8) <> 0 then
      Inc(FBytesPerRow);

    ResourceStream.Read(BmpInfo, SizeOf(BmpInfo)); // Ignore BmpInfo
    SetLength(FCustomCursor.Bits, FBytesPerRow * FHeight);
    SetLength(FCustomCursor.Mask, FBytesPerRow * FHeight);

    ConvertDIB(ResourceStream);
    CreateCursor;
  finally
      ResourceStream.Free;
      SetLength(FCustomCursor.Bits, 0);
      SetLength(FCustomCursor.Mask, 0);
  end;
end;

procedure TWinCursor.LoadFromStream(Stream: TStream);
var
  CURSORDIR: TCURSORDIR;
  Entry: TCURSORDIRENTRY;
  BitmapInfo: TBITMAPINFOHEADER;
begin
  Stream.ReadBuffer(CursorDir, SizeOf(TCursorDir));

  if (CursorDir.cdReserved <> 0) or (CursorDir.cdType <> 2) or (CursorDir.cdCount <> 1) then
    raise EWinCursor.Create(RsUnsupported);

  Stream.Read(Entry, SizeOf(TCURSORDIRENTRY));
  Stream.Seek(Entry.dwImageOffset, soFromBeginning);
  Stream.Read(BitmapInfo, SizeOf(TBITMAPINFOHEADER));

  with Entry do
  begin
    FWidth := bWidth;
    FHeight := bHeight;
    FHotspot.X := wXHotspot;
    FHotspot.Y := wYHotspot
  end;

  Stream.Seek(8, soFromCurrent);
  FBytesPerRow := FWidth div 8;

  if (FWidth mod 8) <> 0 then
    Inc(FBytesPerRow);

  SetLength(FCustomCursor.Bits, FBytesPerRow * FHeight);
  SetLength(FCustomCursor.Mask, FBytesPerRow * FHeight);

  ConvertDib(Stream);
  CreateCursor;
end;

{------------------------------------------------------------------------------}
{                                                                              }
{ Convert Table                                                                }
{                                                                              }