gifanimator.pas

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

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

unit GifAnimator;

interface

uses Messages, Windows, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, Menus, ExtCtrls, Gif_MyRxGIF, Gif_MyRxTimer;

type

  { TMyRxImageControl }

  TMyRxImageControl = class(TGraphicControl)
  private
    FDrawing: Boolean;
    FPaintBuffered: Boolean;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    FGraphic: TGraphic;
    function DoPaletteChange: Boolean;
    procedure AdjustSize; virtual; abstract;
    procedure DoPaintImage; virtual; abstract;
    procedure DoPaintControl;
    procedure PaintDesignRect;
    procedure PaintImage;
    procedure PictureChanged;
    procedure Lock;
    procedure Unlock;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { TGIFAnimator }

  TGifAnimator = class(TMyRxImageControl)
  private
    FAnimate: Boolean;
    FImage: TGIF_Image;
    FTimer: TMyRxTimer;
    FFrameIndex: Integer;
    FStretch: Boolean;
    FLoop: Boolean;
    FCenter: Boolean;
    FTransparent: Boolean;
    FTimerRepaint: Boolean;
    FCache: TBitmap;
    FCacheIndex: Integer;
    FTransColor: TColor;
    FAutoSize: Boolean;
    FOnStart: TNotifyEvent;
    FOnStop: TNotifyEvent;
    FOnChange: TNotifyEvent;
    FOnFrameChanged: TNotifyEvent;
    procedure TimerDeactivate;
    function GetFrameBitmap(Index: Integer; var TransColor: TColor): TBitmap;
    function GetDelayTime(Index: Integer): Cardinal;
    procedure SetAutoSize(Value: Boolean);
    procedure SetAnimate(Value: Boolean);
    procedure SetCenter(Value: Boolean);
    procedure SetImage(Value: TGIF_Image);
    procedure SetFrameIndex(Value: Integer);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure ImageChanged(Sender: TObject);
    procedure TimerExpired(Sender: TObject);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    function GetPalette: HPALETTE; override;
    procedure AdjustSize; override;
    procedure Paint; override;
    procedure DoPaintImage; override;
    procedure Change; dynamic;
    procedure FrameChanged; dynamic;
    procedure Start; dynamic;
    procedure Stop; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Animate: Boolean read FAnimate write SetAnimate default False;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property Center: Boolean read FCenter write SetCenter default False;
    property FrameIndex: Integer read FFrameIndex write SetFrameIndex default 0;
    property Image: TGIF_Image read FImage write SetImage;
    property Loop: Boolean read FLoop write FLoop default True;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default True;
    property Align;
    property Cursor;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnFrameChanged: TNotifyEvent read FOnFrameChanged write FOnFrameChanged;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
    property OnStop: TNotifyEvent read FOnStop write FOnStop;
    property OnClick;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnStartDrag;
  end;

procedure Register;

implementation

uses Gif_Unit, Gif_MyRxGraph;

{ Maximum delay (10 sec) guarantees that a very long and slow
  GIF does not hang the system }
const
  MaxDelayTime = 10000;
  MinDelayTime = 50;

{ TMyRxImageControl }

constructor TMyRxImageControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque,
    csReplicatable, csDoubleClicks];
  Height := 105;
  Width := 105;
  ParentColor := True;
end;

destructor TMyRxImageControl.Destroy;
begin
  inherited Destroy;
end;

procedure TMyRxImageControl.Lock;
begin

end;

procedure TMyRxImageControl.Unlock;
begin

end;

procedure TMyRxImageControl.PaintImage;
var
  Save: Boolean;
begin
  with Canvas do begin
    Brush.Color := Color;
    FillRect(Bounds(0, 0, ClientWidth, ClientHeight));
  end;
  Save := FDrawing;
  FDrawing := True;
  try
    DoPaintImage;
  finally
    FDrawing := Save;
  end;
end;

procedure TMyRxImageControl.WMPaint(var Message: TWMPaint);
var
  DC, MemDC: HDC;
  MemBitmap, OldBitmap: HBITMAP;
begin
  if FPaintBuffered then
    inherited
  else if Message.DC <> 0 then begin
    DC := Message.DC;
    MemDC := GetDC(0);
    MemBitmap := CreateCompatibleBitmap(MemDC, ClientWidth, ClientHeight);
    ReleaseDC(0, MemDC);
    MemDC := CreateCompatibleDC(0);
    OldBitmap := SelectObject(MemDC, MemBitmap);
    try
      FPaintBuffered := True;
      try
        Message.DC := MemDC;
        WMPaint(Message);
        Message.DC := 0;
      finally
        FPaintBuffered := False;
      end;
      BitBlt(DC, 0, 0, ClientWidth, ClientHeight, MemDC, 0, 0, SRCCOPY);
    finally
      SelectObject(MemDC, OldBitmap);
      DeleteDC(MemDC);
      DeleteObject(MemBitmap);
    end;
  end;
end;

procedure TMyRxImageControl.PaintDesignRect;
begin
  if csDesigning in ComponentState then
    with Canvas do begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
end;

procedure TMyRxImageControl.DoPaintControl;
var
  DC: HDC;
begin
  DC := GetDC(Parent.Handle);
  try
    IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);
    MoveWindowOrg(DC, Left, Top);
    Perform(WM_PAINT, DC, 0);
  finally
    ReleaseDC(Parent.Handle, DC);
  end;
end;

function TMyRxImageControl.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := FGraphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) then
  begin
    if (GetPalette <> 0) then begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and ParentForm.Active and ParentForm.HandleAllocated then
      begin
        if FDrawing then
          ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
        else
          PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
        Result := True;
      end;
    end;
  end;
end;

procedure TMyRxImageControl.PictureChanged;
begin
  if not (csDestroying in ComponentState) then begin
    AdjustSize;
    if (FGraphic <> nil) then
      if DoPaletteChange and FDrawing then Update;
    if not FDrawing then Invalidate;
  end;
end;

{ TGifAnimator }

constructor TGifAnimator.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTimer := TMyRxTimer.Create(Self);
  AutoSize := True;
  FImage := TGIF_Image.Create;
  FGraphic := FImage;
  FImage.OnChange := ImageChanged;
  FCacheIndex := -1;
  FTransColor := clNone;
  FLoop := True;
  FTransparent := True;
end;

destructor TGifAnimator.Destroy;
begin
  Destroying;
  FOnStart := nil;
  FOnStop := nil;
  FOnChange := nil;
  FOnFrameChanged := nil;
  Animate := False;
  FCache.Free;
  FImage.OnChange := nil;
  FImage.Free;
  inherited Destroy;
end;

procedure TGifAnimator.AdjustSize;
begin
  if not (csReading in ComponentState) then begin
    if AutoSize and Assigned(FImage) and not FImage.Empty then
      SetBounds(Left, Top, FImage.ScreenWidth, FImage.ScreenHeight);
  end;
end;

function TGifAnimator.GetDelayTime(Index: Integer): Cardinal;
begin
  if (FFrameIndex >= 0) and (FFrameIndex < FImage.Count) and
    (FImage.Count > 1) then
  begin
    Result := FImage.Frames[FFrameIndex].AnimateInterval;
    if Result < MinDelayTime then Result := MinDelayTime
    else if Result > MaxDelayTime then Result := MaxDelayTime;
  end
  else Result := 0;
end;