aniimg.pas

一个方便显示动画的delphi控件

{------------------------------------------------------------------------------}
{                                                                              }
{  TAnimateImage v1.02                                                         }
{  by Kambiz R. Khojasteh                                                      }
{                                                                              }
{  [e-mail]                                                       }
{  http://www.delphiarea.com                                                   }
{                                                                              }
{------------------------------------------------------------------------------}

{$I DELPHIAREA.INC}

unit AniImg;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Graphics, ExtCtrls,
  Menus, {$IFNDEF COMPILER4_UP} ComCtrls {$ELSE} ImgList {$ENDIF};

{$IFNDEF COMPILER4_UP}
type TCustomImageList = class(TImageList);
{$ENDIF}

{$IFNDEF COMPILER5_UP}
type TImageIndex = type Integer;
{$ENDIF}

type
  TAnimateImage = class(TGraphicControl)
  private
    FActive: Boolean;
    FCenter: Boolean;
    FTransparent: Boolean;
    {$IFNDEF COMPILER4_UP}
    FAutoSize: Boolean;
    {$ENDIF}
    FFrameIndex: TImageIndex;
    FStartFrame: TImageIndex;
    FStopFrame: TImageIndex;
    FReverse: Boolean;
    FNumLoops: Integer;
    FLoopCount: Integer;
    FDoubleBuffered: Boolean;
    FImages: TCustomImageList;
    FImageChangeLink: TChangeLink;
    FTimer: TTimer;
    FOnFrame: TNotifyEvent;
    FOnWrap: TNotifyEvent;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    procedure SetActive(Value: Boolean);
    procedure SetCenter(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    {$IFNDEF COMPILER4_UP}
    procedure SetAutoSize(Value: Boolean);
    {$ENDIF}
    function GetInterval: Integer;
    procedure SetInterval(Value: Integer);
    procedure SetFrameIndex(Value: TImageIndex);
    procedure SetStartFrame(Value: TImageIndex);
    procedure SetStopFrame(Value: TImageIndex);
    procedure SetImages(Value: TCustomImageList);
    procedure ImageListChange(Sender: TObject);
    procedure TimerExpired(Sender: TObject);
    procedure CheckTimer;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    {$IFDEF COMPILER4_UP}
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    {$ENDIF}
    procedure Loaded; override;
    procedure Paint; override;
    {$IFNDEF COMPILER4_UP}
    procedure AdjustSize;
    {$ENDIF}
    procedure PaintFrame(C: TCanvas);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property LoopCount: Integer read FLoopCount;
  published
    property Active: Boolean read FActive write SetActive default False;
    property Align;
    {$IFDEF COMPILER4_UP}
    property Anchors;
    {$ENDIF}
    {$IFDEF COMPILER4_UP}
    property AutoSize;
    {$ELSE}
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    {$ENDIF}
    property Center: Boolean read FCenter write SetCenter default True;
    property Color;
    {$IFDEF COMPILER4_UP}
    property Constraints;
    {$ENDIF}
    property DragCursor;
    {$IFDEF COMPILER4_UP}
    property DragKind;
    {$ENDIF}
    property DragMode;
    property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered default False;
    property Enabled;
    property FrameIndex: TImageIndex read FFrameIndex write SetFrameIndex default 0;
    property Height default 100;
    property Interval: Integer read GetInterval write SetInterval default 250;
    property Images: TCustomImageList read FImages write SetImages;
    property NumLoops: Integer read FNumLoops write FNumLoops default 0;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property Reverse: Boolean read FReverse write FReverse default False;
    property ShowHint;
    property StartFrame: TImageIndex read FStartFrame write SetStartFrame default 0;
    property StopFrame: TImageIndex read FStopFrame write SetStopFrame default 0;
    property Transparent: Boolean read FTransparent write SetTransparent default True;
    property Visible;
    property Width default 100;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF COMPILER4_UP}
    property OnEndDock;
    {$ENDIF}
    property OnEndDrag;
    property OnFrame: TNotifyEvent read FOnFrame write FOnFrame;
    property OnMouseDown;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    {$IFDEF COMPILER4_UP}
    property OnStartDock;
    {$ENDIF}
    property OnStartDrag;
    property OnWrap: TNotifyEvent read FOnWrap write FOnWrap;
  end;

procedure Register;

implementation

type
  TParentControl = class(TWinControl);

{ This procedure is copied from RxLibrary VCLUtils }
procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
{$IFDEF WIN32}
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
{$ENDIF}
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      with TParentControl(Control.Parent) do
      begin
        Perform(WM_ERASEBKGND, DC, 0);
        PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    { Copy images of graphic controls }
    for I := 0 to Count - 1 do begin
      if Control.Parent.Controls[I] = Control then Break
      else if (Control.Parent.Controls[I] <> nil) and
        (Control.Parent.Controls[I] is TGraphicControl) then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
{$IFDEF WIN32}
            ControlState := ControlState + [csPaintCopy];
{$ENDIF}
            SaveIndex := SaveDC(DC);
            try
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
{$IFDEF WIN32}
              ControlState := ControlState - [csPaintCopy];
{$ENDIF}
            end;
          end;
        end;
      end;
    end;
{$IFDEF WIN32}
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
{$ENDIF}
end;

{ TAnimateImage }

constructor TAnimateImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  SetBounds(Left, Top, 100, 100);
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FTimer := TTimer.Create(nil);
  FTimer.Enabled := False;
  FTimer.Interval := 250;
  FTimer.OnTimer := TimerExpired;
  FTransparent := True;
  FCenter := True;
end;

destructor TAnimateImage.Destroy;
begin
  FTimer.Free;
  FImageChangeLink.Free;
  inherited Destroy;
end;

procedure TAnimateImage.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = Images) then
    SetImages(nil);
end;

{$IFNDEF COMPILER4_UP}
procedure TAnimateImage.AdjustSize;
begin
  if FImages <> nil then
  begin
    if Align in [alNone, alLeft, alRight] then
      Width := FImages.Width;
    if Align in [alNone, alTop, alBottom] then
      Height := FImages.Height;
  end;
end;
{$ENDIF}

{$IFDEF COMPILER4_UP}
function TAnimateImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if FImages <> nil then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := FImages.Width;
    if Align in [alNone, alTop, alBottom] then
      NewHeight := FImages.Height;
  end;
end;
{$ENDIF}

procedure TAnimateImage.Loaded;
begin
  inherited Loaded;
  CheckTimer;
end;

procedure TAnimateImage.Paint;
var
  B: TBitmap;
begin
  if FDoubleBuffered then
  begin
    B := TBitmap.Create;
    try
      B.Width := Width;
      B.Height := Height;
      PaintFrame(B.Canvas);
      Canvas.Draw(0, 0, B);
    finally
      B.Free;
    end;
  end
  else
    PaintFrame(Canvas);
  if csDesigning in ComponentState then
  begin
    Canvas.Pen.Style := psDash;
    Canvas.Brush.Style := bsClear;
    Canvas.Rectangle(0, 0, Width, Height);
  end;
end;

procedure TAnimateImage.PaintFrame(C: TCanvas);
begin
  if FTransparent then
    CopyParentImage(Self, C)
  else
  begin
    C.Brush.Color := Color;
    C.FillRect(ClientRect);
  end;
  if (FImages <> nil) and (FFrameIndex >= 0) then
  begin
    if FCenter then
      FImages.Draw(C, (Width - FImages.Width) div 2, (Height - FImages.Height) div 2, FFrameIndex)
    else
      FImages.Draw(C, 0, 0, FFrameIndex);
  end;
end;

procedure TAnimateImage.ImageListChange(Sender: TObject);
begin
  if not (csLoading in ComponentState) then
  begin
    FStartFrame := 0;
    if (FImages <> nil) and (FImages.Count > 1) then
      FStopFrame := FImages.Count - 1
    else
      FStopFrame := 0;
    if FFrameIndex < FStartFrame then
      FFrameIndex := FStartFrame
    else if FFrameIndex > FStopFrame then
      FFrameIndex := FStopFrame;
    if AutoSize then AdjustSize;
    Invalidate;
    CheckTimer;
  end;
end;

procedure TAnimateImage.TimerExpired(Sender: TObject);
var
  NewFrameIndex: Integer;
  Wrapped: Boolean;
begin
  Wrapped := False;
  if FReverse then
  begin
    NewFrameIndex := FFrameIndex - 1;
    if NewFrameIndex < FStartFrame then
    begin
      NewFrameIndex := FStopFrame;
      Wrapped := True;
    end;
  end
  else
  begin
    NewFrameIndex := FFrameIndex + 1;
    if NewFrameIndex > FStopFrame then
    begin
      NewFrameIndex := FStartFrame;
      Wrapped := True;
    end;
  end;
  if Wrapped then
  begin
    Inc(FLoopCount);
    if Assigned(FOnWrap) then
      FOnWrap(Self);
    if (FNumLoops <> 0) and (FLoopCount >= FNumLoops) then
      SetActive(False);
  end;
  if FActive then
  begin
    SetFrameIndex(NewFrameIndex);
    if Assigned(FOnFrame) then
      FOnFrame(Self);
  end;
end;

procedure TAnimateImage.CheckTimer;
var
  WasEnabled: Boolean;
begin
  if not (csLoading in ComponentState) then
  begin
    WasEnabled := FTimer.Enabled;
    FTimer.Enabled := FActive and (FStopFrame - StartFrame > 0);
    if FTimer.Enabled and not WasEnabled then
    begin
      FLoopCount := 0;
      if FReverse then
        SetFrameIndex(FStopFrame)
      else
        SetFrameIndex(FStartFrame);
    end;
  end;
end;

procedure TAnimateImage.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
end;

procedure TAnimateImage.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
end;

procedure TAnimateImage.SetActive(Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    CheckTimer;
  end;
end;

{$IFNDEF COMPILER4_UP}
procedure TAnimateImage.SetAutoSize(Value: Boolean);
begin
  if Value <> AutoSize then
  begin
    FAutoSize := Value;
    if FAutoSize then AdjustSize;
  end;
end;
{$ENDIF}

procedure TAnimateImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;

procedure TAnimateImage.SetFrameIndex(Value: TImageIndex);
begin
  if Value < -1 then Value := -1;
  if not (csLoading in ComponentState) then
  begin
    if (FFrameIndex <> Value) and ((Value < 0) or
       ((Value >= FStartFrame) and (Value <= FStopFrame))) then
    begin
      FFrameIndex := Value;
      Invalidate;
    end;
  end
  else
    FFrameIndex := Value;
end;

procedure TAnimateImage.SetImages(Value: TCustomImageList);
begin
  if FImages <> Value then
  begin
    if FImages <> nil then
      FImages.UnRegisterChanges(FImageChangeLink);
    FImages := Value;
    if FImages <> nil then
    begin
      FImages.RegisterChanges(FImageChangeLink);
      FImages.FreeNotification(Self);
    end;
    ImageListChange(nil);
  end;
end;

procedure TAnimateImage.SetStartFrame(Value: TImageIndex);
begin
  if Value < 0 then Value := 0;
  if not (csLoading in ComponentState) then
  begin
    if (FStartFrame <> Value) and (Value <= FStopFrame) then
    begin
      FStartFrame := Value;
      if (FFrameIndex < FStartFrame) and (FFrameIndex >= 0) then
      begin
        FFrameIndex := FStartFrame;
        Invalidate;
      end;
      CheckTimer;
    end;
  end
  else
    FStartFrame := Value;
end;

procedure TAnimateImage.SetStopFrame(Value: TImageIndex);
begin
  if Value < 0 then Value := 0;
  if not (csLoading in ComponentState) then
  begin
    if (FStopFrame <> Value) and (Value >= FStartFrame) and
       (FImages <> nil) and (Value < FImages.Count) then
    begin
      FStopFrame := Value;
      if FFrameIndex > FStopFrame then
      begin
        FFrameIndex := FStopFrame;
        Invalidate;
      end;
      CheckTimer;
    end;
  end
  else
    FStopFrame := Value;
end;

procedure TAnimateImage.SetTransparent(Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;

function TAnimateImage.GetInterval: Integer;
begin
  Result := FTimer.Interval;
end;

procedure TAnimateImage.SetInterval(Value: Integer);
begin
  FTimer.Interval := Value;
end;

procedure Register;
begin
  RegisterComponents('Delphi Area', [TAnimateImage]);
end;

end.