gif_anifile.pas

可以用来显示 Gif 的VCL控件 完整源码版本

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (MyRx)                    }
{                                                       }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}

unit Gif_AniFile;

interface

uses SysUtils, Windows, Classes, Graphics, RTLConsts;

type
  TFourCC = array[0..3] of Char;

  PAniTag = ^TAniTag;
  TAniTag = packed record
    ckID: TFourCC;
    ckSize: Longint;
  end;

  TAniHeader = packed record
    cbSizeOf: Longint;
    cSteps: Longint;
    cFrames: Longint;
    cReserved: array[0..3] of Longint;
    jifRate: Longint; { 1 Jiffy = 1/60 sec }
    fl: Longint;
  end;

const
  AF_ICON     = $00000001;
  AF_SEQUENCE = $00000002;

type
  TIconFrame = class(TPersistent)
  private
    FIcon: TIcon;
    FIsIcon: Boolean;
    FTag: TAniTag;
    FHotSpot: TPoint;
    FJiffRate: Longint;
    FSeq: Integer;
  public
    constructor Create(Index: Integer; Jiff: Longint);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property JiffRate: Longint read FJiffRate;
    property Seq: Integer read FSeq;
  end;

{ TAnimatedCursorImage }

  TANINAME = array[0..255] of Char;

  TAnimatedCursorImage = class(TPersistent)
  private
    FHeader: TAniHeader;
    FTitle: TANINAME;
    FCreator: TANINAME;
    FIcons: TList;
    FOriginalColors: Word;
    procedure NewImage;
    procedure RiffReadError;
    function ReadCreateIcon(Stream: TStream; ASize: Longint;
      var HotSpot: TPoint; var IsIcon: Boolean): TIcon;
    function GetIconCount: Integer;
    function GetIcon(Index: Integer): TIcon;
    function GetFrame(Index: Integer): TIconFrame;
    function GetTitle: string;
    function GetCreator: string;
    function GetDefaultRate: Longint;
    procedure ReadAniStream(Stream: TStream);
    procedure ReadStream(Size: Longint; Stream: TStream);
    procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure Draw(ACanvas: TCanvas; const ARect: TRect);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    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);
    property DefaultRate: Longint read GetDefaultRate;
    property IconCount: Integer read GetIconCount;
    property Icons[Index: Integer]: TIcon read GetIcon;
    property Frames[Index: Integer]: TIconFrame read GetFrame;
    property Title: string read GetTitle;
    property Creator: string read GetCreator;
    property OriginalColors: Word read FOriginalColors;
  end;

implementation

{ This implementation based on animated cursor editor source code
  (ANIEDIT.C, copyright (C) Microsoft Corp., 1993-1996) }

uses Consts, Gif_MyRxGraph, Gif_Unit, Gif_IcoList;

const
  FOURCC_ACON = 'ACON';
  FOURCC_RIFF = 'RIFF';
  FOURCC_INFO = 'INFO';
  FOURCC_INAM = 'INAM';
  FOURCC_IART = 'IART';
  FOURCC_LIST = 'LIST';
  FOURCC_anih = 'anih';
  FOURCC_rate = 'rate';
  FOURCC_seq  = 'seq ';
  FOURCC_fram = 'fram';
  FOURCC_icon = 'icon';

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

procedure DecreaseBMPColors(Bmp: TBitmap; Colors: Integer);
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;
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; pTag: PAniTag): Boolean;
begin
  pTag^.ckID := #0#0#0#0;
  pTag^.ckSize := 0;
  Result := S.Read(pTag^, SizeOf(TAniTag)) = SizeOf(TAniTag);
end;

function ReadChunk(S: TStream; pTag: PAniTag; Data: Pointer): Boolean;
begin
  Result := S.Read(Data^, pTag^.ckSize) = pTag^.ckSize;
  if Result then
    Result := S.Seek(pTag^.ckSize mod 2, soFromCurrent) <> -1;
end;

function ReadChunkN(S: TStream; pTag: PAniTag; Data: Pointer;
  cbMax: Longint): Boolean;
var
  cbRead: Longint;
begin
  cbRead := pTag^.ckSize;
  if cbMax < cbRead then cbRead := cbMax;
  Result := S.Read(Data^, cbRead) = cbRead;
  if Result then begin
    cbRead := PadUp(pTag^.ckSize) - cbRead;
    Result := S.Seek(cbRead, soFromCurrent) <> -1;
  end;
end;

function SkipChunk(S: TStream; pTag: PAniTag): Boolean;
begin
  { Round pTag^.ckSize up to nearest word boundary to maintain alignment }
  Result := S.Seek(PadUp(pTag^.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;

{ TIconFrame }

constructor TIconFrame.Create(Index: Integer; Jiff: Longint);
begin
  inherited Create;
  FSeq := Index;
  FJiffRate := Jiff;
end;

destructor TIconFrame.Destroy;
begin
  if FIcon <> nil then FIcon.Free;
  inherited Destroy;
end;

procedure TIconFrame.Assign(Source: TPersistent);
begin
  if Source is TIconFrame then begin
    with TIconFrame(Source) do begin
      if Self.FIcon = nil then Self.FIcon := TIcon.Create;
      Self.FIcon.Assign(FIcon);
      Self.FIsIcon := FIsIcon;
      Move(FTag, Self.FTag, SizeOf(TAniTag));
      Self.FHotSpot.X := FHotSpot.X;
      Self.FHotSpot.Y := FHotSpot.Y;
      Self.FJiffRate := FJiffRate;
      Self.FSeq := FSeq;
    end;
  end
  else inherited Assign(Source);
end;

{ TAnimatedCursorImage }

constructor TAnimatedCursorImage.Create;
begin
  inherited Create;
  FIcons := TList.Create;
end;

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

procedure TAnimatedCursorImage.Clear;
begin
  NewImage;
end;

procedure TAnimatedCursorImage.NewImage;
var
  I: Integer;
begin
  for I := 0 to FIcons.Count - 1 do TIconFrame(FIcons[I]).Free;
  FIcons.Clear;
  FillChar(FTitle, SizeOf(FTitle), 0);
  FillChar(FCreator, SizeOf(FCreator), 0);
  FillChar(FHeader, SizeOf(FHeader), 0);
  FOriginalColors := 0;
end;

procedure TAnimatedCursorImage.RiffReadError;
begin
  raise EReadError.Create(ResStr(SReadError));
end;

function TAnimatedCursorImage.GetTitle: string;
begin
  Result := StrPas(FTitle);
end;

function TAnimatedCursorImage.GetCreator: string;
begin
  Result := StrPas(FCreator);
end;

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

function TAnimatedCursorImage.GetIcon(Index: Integer): TIcon;
begin
  Result := TIconFrame(FIcons[Index]).FIcon;
end;

function TAnimatedCursorImage.GetFrame(Index: Integer): TIconFrame;
begin
  Result := TIconFrame(FIcons[Index]);
end;

function TAnimatedCursorImage.GetDefaultRate: Longint;
begin
  Result := Max(0, Min((FHeader.jifRate * 100) div 6, High(Result)));
end;

procedure TAnimatedCursorImage.Assign(Source: TPersistent);
var
  I: Integer;
  Frame: TIconFrame;
begin
  if Source = nil then begin
    Clear;
  end
  else if Source is TAnimatedCursorImage then begin
    NewImage;
    try
      with TAnimatedCursorImage(Source) do begin
        Move(FHeader, Self.FHeader, SizeOf(FHeader));
        Self.FTitle := FTitle;
        Self.FCreator := FCreator;
        Self.FOriginalColors := FOriginalColors;
        for I := 0 to FIcons.Count - 1 do begin
          Frame := TIconFrame.Create(-1, FHeader.jifRate);
          try
            Frame.Assign(TIconFrame(FIcons[I]));
            Self.FIcons.Add(Frame);
          except
            Frame.Free;
            raise;
          end;