jvanifile.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
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/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvAniFile.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 2001,2002 SGB Software
All Rights Reserved.

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvAniFile.pas,v 1.38 2005/02/17 10:19:58 marquardt Exp $

unit JvAniFile;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Classes,
  {$IFDEF HAS_UNIT_RTLCONSTS}
  RTLConsts,
  {$ENDIF HAS_UNIT_RTLCONSTS}
  Windows, Graphics,
  JvTypes;

type
  TJvIconFrame = class(TPersistent)
  private
    FIcon: TIcon;
    FIsIcon: Boolean;
    FHotSpot: TPoint;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Icon: TIcon read FIcon;
    property HotSpot: TPoint read FHotSpot;
  end;

  TJvAnimatedCursorImage = class(TPersistent)
  private
    FHeader: TJvAniHeader;
    FTitle: string;
    FCreator: string;
    FIcons: TList;
    FOriginalColors: Word;
    FIndex: Integer;
    FRates: array of Longint;
    FSequence: array of Longint;
    FFrameCount: Integer;
    procedure NewImage;
    procedure RiffReadError;
    function ReadCreateIcon(Stream: TStream; ASize: Longint;
      var HotSpot: TPoint; var IsIcon: Boolean): TIcon;
    function GetIconCount: Integer;
    function GetFrameCount: Integer;
    function GetIcons(Index: Integer): TIcon;
    function GetFrames(Index: Integer): TJvIconFrame;
    function GetRates(Index: Integer): Longint;
    procedure SetIndex(Value: Integer);
    procedure ReadAniStream(Stream: TStream);
    procedure WriteAniStream(Stream: TStream);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure Draw(ACanvas: TCanvas; const ARect: TRect);
    procedure Clear;
    procedure LoadFromStream(Stream: TStream); virtual;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromFile(const FileName: string); virtual;
    procedure AssignToBitmap(Bitmap: TBitmap; BackColor: TColor;
      DecreaseColors, Vertical: Boolean); // DecreaseBMPColors does nothing under VisualCLX
    property IconCount: Integer read GetIconCount;
    property FrameCount: Integer read GetFrameCount;
    property Icons[Index: Integer]: TIcon read GetIcons;
    property Frames[Index: Integer]: TJvIconFrame read GetFrames;
    property Rates[Index: Integer]: Longint read GetRates;
    property Title: string read FTitle write FTitle;
    property Creator: string read FCreator write FCreator;
    property OriginalColors: Word read FOriginalColors;
    property Header: TJvAniHeader read FHeader;
    property Index: Integer read FIndex write SetIndex;
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvAniFile.pas,v $';
    Revision: '$Revision: 1.38 $';
    Date: '$Date: 2005/02/17 10:19:58 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysUtils,
  Consts, Math,
  JvJVCLUtils, JvJCLUtils, JvIconList, JvConsts, JvResources;

function PadUp(Value: Longint): Longint;
begin
  Result := Value + (Value mod 2); // Up Value to nearest word boundary
end;

procedure DecreaseBMPColors(Bmp: TBitmap; Colors: Integer);
{$IFDEF VCL}
var
  Stream: TStream;
begin
  if (Bmp <> nil) and (Colors > 0) then
  begin
    Stream := BitmapToMemory(Bmp, Colors);
    try
      Bmp.LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
{$ENDIF VCL}
{$IFDEF VisualCLX}
begin
  // TODO
end;
{$ENDIF VisualCLX}
end;

function GetDInColors(BitCount: Word): Integer;
begin
  case BitCount of
    1, 4, 8:
      Result := 1 shl BitCount;
  else
    Result := 0;
  end;
end;

{ ReadTag, ReadChunk, SkipChunk. Some handy functions for reading RIFF files. }

function ReadTag(S: TStream; var Tag: TJvAniTag): Boolean;
begin
  Tag.ckID := #0#0#0#0;
  Tag.ckSize := 0;
  Result := S.Read(Tag, SizeOf(TJvAniTag)) = SizeOf(TJvAniTag);
end;

function ReadChunk(S: TStream; const Tag: TJvAniTag; var Data): Boolean;
begin
  Result := S.Read(Data, Tag.ckSize) = Tag.ckSize;
  if Result then
    Result := S.Seek(Tag.ckSize mod 2, soFromCurrent) <> -1;
end;

function ReadChunkN(S: TStream; const Tag: TJvAniTag; var Data;
  cbMax: Longint): Boolean;
var
  cbRead: Longint;
begin
  FillChar(Data, cbMax, #0);
  cbRead := Tag.ckSize;
  if cbMax < cbRead then
    cbRead := cbMax;
  Result := S.Read(Data, cbRead) = cbRead;
  if Result then
  begin
    cbRead := PadUp(Tag.ckSize) - cbRead;
    Result := S.Seek(cbRead, soFromCurrent) <> -1;
  end;
end;

function SkipChunk(S: TStream; const Tag: TJvAniTag): Boolean;
begin
  // Round pTag^.ckSize up to nearest word boundary to maintain alignment
  Result := S.Seek(PadUp(Tag.ckSize), soFromCurrent) <> -1;
end;

{ Icon and cursor types }

const
  RC3_STOCKICON = 0;
  RC3_ICON = 1;
  RC3_CURSOR = 2;

type
  PCursorOrIcon = ^TCursorOrIcon;
  TCursorOrIcon = packed record
    Reserved: Word;
    wType: Word;
    Count: Word;
  end;

  PIconRec = ^TIconRec;
  TIconRec = packed record
    Width: Byte;
    Height: Byte;
    Colors: Word;
    xHotspot: Word;
    yHotspot: Word;
    DIBSize: Longint;
    DIBOffset: Longint;
  end;

//=== { TJvIconFrame } =======================================================

destructor TJvIconFrame.Destroy;
begin
  FIcon.Free;
  inherited Destroy;
end;

procedure TJvIconFrame.Assign(Source: TPersistent);
begin
  if Source is TJvIconFrame then
    with Source as TJvIconFrame do
    begin
      if Self.FIcon = nil then
        Self.FIcon := TIcon.Create;
      Self.FIcon.Assign(Icon);
      Self.FIsIcon := FIsIcon;
      Self.FHotSpot := HotSpot;
    end
  else
    inherited Assign(Source);
end;

//=== { TJvAnimatedCursorImage } =============================================

constructor TJvAnimatedCursorImage.Create;
begin
  inherited Create;
  FIcons := TList.Create;
  FIndex := 0;
end;

destructor TJvAnimatedCursorImage.Destroy;
begin
  NewImage;
  FIcons.Free;
  inherited Destroy;
end;

procedure TJvAnimatedCursorImage.Clear;
begin
  NewImage;
end;

procedure TJvAnimatedCursorImage.NewImage;
var
  I: Integer;
begin
  for I := 0 to FIcons.Count - 1 do
    TJvIconFrame(FIcons[I]).Free;
  FIcons.Clear;
  SetLength(FRates, 0);
  SetLength(FSequence, 0);
  FFrameCount := 0;
  FTitle := '';
  FCreator := '';
  FillChar(FHeader, SizeOf(FHeader), 0);
  FOriginalColors := 0;
end;

procedure TJvAnimatedCursorImage.RiffReadError;
begin
  raise EReadError.CreateRes(@SReadError);
end;

function TJvAnimatedCursorImage.GetIconCount: Integer;
begin
  Result := FIcons.Count;
end;

function TJvAnimatedCursorImage.GetFrameCount: Integer;
begin
  Result := FFrameCount;
end;

function TJvAnimatedCursorImage.GetIcons(Index: Integer): TIcon;
begin
  if (Index >= 0) and (Index < IconCount) then
    Result := TJvIconFrame(FIcons[Index]).FIcon
  else
    Result := nil;
end;

function TJvAnimatedCursorImage.GetFrames(Index: Integer): TJvIconFrame;
begin
  if (Index >= 0) and (Index < FrameCount) then
  begin
    if Index < Length(FSequence) then
      Result := TJvIconFrame(FIcons[FSequence[Index]])
    else
      Result := TJvIconFrame(FIcons[Index]);
  end
  else
    Result := nil;
end;

function TJvAnimatedCursorImage.GetRates(Index: Integer): Longint;
begin
  if (Index >= 0) and (Index < Length(FRates)) then
    Result := FRates[Index]
  else
    Result := Header.dwJIFRate;
end;

procedure TJvAnimatedCursorImage.SetIndex(Value: Integer);
begin
  if (Value >= 0) and (Value < FrameCount) then
    FIndex := Value;
end;

procedure TJvAnimatedCursorImage.Assign(Source: TPersistent);
var
  I: Integer;
  Frame: TJvIconFrame;
begin
  if Source = nil then
    Clear
  else
  if Source is TJvAnimatedCursorImage then
  begin
    NewImage;
    try
      with TJvAnimatedCursorImage(Source) do
      begin
        Move(FHeader, Self.FHeader, SizeOf(FHeader));
        Self.FTitle := Title;
        Self.FCreator := Creator;
        Self.FOriginalColors := FOriginalColors;
        Self.FFrameCount := FrameCount;
        SetLength(Self.FRates, Length(FRates));
        if Length(FRates) <> 0 then
          Move(FRates[0], Self.FRates[0], Length(FRates)*SizeOf(Longint));
        SetLength(Self.FSequence, Length(FSequence));
        if Length(FSequence) <> 0 then
          Move(FSequence[0], Self.FSequence[0], Length(FSequence)*SizeOf(Longint));
        for I := 0 to FIcons.Count - 1 do
        begin
          Frame := TJvIconFrame.Create;
          try
            Frame.Assign(TJvIconFrame(FIcons[I]));
            Self.FIcons.Add(Frame);
          except
            Frame.Free;
            raise;
          end;
        end;
      end;
    except
      NewImage;
      raise;
    end;
  end
  else
    inherited Assign(Source);
end;

procedure TJvAnimatedCursorImage.AssignTo(Dest: TPersistent);
var
  I: Integer;
begin
  if Dest is TIcon then
  begin
    if IconCount > 0 then
      Dest.Assign(Icons[Index])
    else
      Dest.Assign(nil);
  end
  else
  if Dest is TBitmap then
  begin
    if IconCount > 0 then
      AssignToBitmap(TBitmap(Dest), TBitmap(Dest).Canvas.Brush.Color, True, False)
    else
      Dest.Assign(nil);
  end
  else
  if Dest is TJvIconList then
  begin
    TJvIconList(Dest).BeginUpdate;
    try
      TJvIconList(Dest).Clear;
      for I := 0 to FrameCount - 1 do
        TJvIconList(Dest).Add(Frames[I].Icon);
    finally
      TJvIconList(Dest).EndUpdate;
    end;
  end
  else
    inherited AssignTo(Dest);
end;

function TJvAnimatedCursorImage.ReadCreateIcon(Stream: TStream; ASize: Longint;
  var HotSpot: TPoint; var IsIcon: Boolean): TIcon;
type
  PIconRecArray = ^TIconRecArray;
  TIconRecArray = array [0..300] of TIconRec;
var
  List: PIconRecArray;
  Mem: TMemoryStream;
  HeaderLen, I: Integer;
  BI: PBitmapInfoHeader;
begin
  Result := nil;
  Mem := TMemoryStream.Create;
  try