picshow.pas

TPicShow是一套图形平滑特效控制组件

{------------------------------------------------------------------------------}
{                                                                              }
{  TCustomPicShow v3.08                                                        }
{  by Kambiz R. Khojasteh                                                      }
{                                                                              }
{  [e-mail]                                                       }
{  http://www.delphiarea.com                                                   }
{                                                                              }
{  Special thanks to:                                                          }
{  :: <[e-mail]> for help on D5 support.                               }
{  :: Douglass Titjan <[e-mail]> for help on D5 support.        }
{  :: Jerry McLain <[e-mail]> for manual control idea.           }
{  :: M. R. Zamani <[e-mail]> for adding 8 effects (110..117).     }
{  :: Elliott Shevin <[e-mail]> for adding 4 effects (123..126).        }
{  :: Ken Otto <[e-mail]> for adding native JPG support to         }
{     TDBPicShow and fixing a memory leak bug.                                 }
{  :: Gary Bond <[e-mail]> for name of the transitions.             }
{  :: Viatcheslav V. Vassiliev <[e-mail]> for optimizing the            }
{     thread's termination.                                                    }
{  :: Miguel Gastelumendi Dargent <[e-mail]> for fixing the         }
{     possible off-screen problem on the first time transition.                }
{  :: Terry Bogard <[e-mail]> for fixing the bug in       }
{     choosing transition style by name.                                       }
{                                                                              }
{------------------------------------------------------------------------------}

{$I DELPHIAREA.INC}

unit PicShow;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, DB, DBCtrls, JPEG, PSEffect;

const
  PS_THREADTERMINATED = WM_USER + 1;

type

  TPercent = 0..100;

  TShowStyle = 0..High(PSEffects);

  TBackgroundMode = (bmNone, bmTiled, bmStretched, bmCentered);

  TCustomDrawEvent = procedure(Sender: TObject; Picture, Screen: TBitmap) of object;

  TAbout = class(TObject);

{ TCustomPicShow }

  TCustomPicShow = class(TCustomControl)
  private
    fAbout: TAbout;
    fPicture: TPicture;
    fBgPicture: TPicture;
    fBgMode: TBackgroundMode;
    fAutoSize: Boolean;
    fCenter: Boolean;
    fStretch: Boolean;
    fStretchFine: Boolean;
    fOverDraw: Boolean;
    fThreaded: Boolean;
    fThreadPriority: TThreadPriority;
    fManual: Boolean;
    fStyle: TShowStyle;
    fStep: Word;
    fDelay: Word;
    fProgress: TPercent;
    fReverse: Boolean;
    fBusy: Boolean;
    fOnChange: TNotifyEvent;
    fOnProgress: TNotifyEvent;
    fOnComplete: TNotifyEvent;
    fOnCustomDraw: TCustomDrawEvent;
    fOnMouseEnter: TNotifyEvent;
    fOnMouseLeave: TNotifyEvent;
    fOnBeforeNewFrame: TCustomDrawEvent;
    fOnAfterNewFrame: TCustomDrawEvent;
    fOnStart: TCustomDrawEvent;
    fOnStop: TNotifyEvent;
    Media: TBitmap;
    PicRect: TRect;
    Thread: TThread;
    Drawing: Boolean;
    OffScreen: TBitmap;
    Stopping: Boolean;
    NeverDrawn: Boolean;
    OldPic: TBitmap;
    Pic: TBitmap;
    PicWidth: Integer;
    PicHeight: Integer;
    CS: TRTLCriticalSection;
    UpdateEvent: THandle;
    procedure SetAutoSize_(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetBgPicture(Value: TPicture);
    procedure SetBgMode(Value: TBackgroundMode);
    procedure SetCenter(Value: Boolean);
    procedure SetStretch(Value: Boolean);
    procedure SetStretchFine(Value: Boolean);
    procedure SetStep(Value: Word);
    procedure SetProgress(Value: TPercent);
    procedure SetManual(Value: Boolean);
    procedure SetStyle(Value: TShowStyle);
    procedure SetStyleName(const Value: String);
    function GetStyleName: String;
    function GetEmpty: Boolean;
    procedure PictureChange(Sender: TObject);
    procedure BgPictureChange(Sender: TObject);
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure WMDestroy(var Msg: TMessage); message WM_DESTROY;
    procedure ThreadTerminated(var Msg: TMessage); message PS_THREADTERMINATED;
  protected
    procedure PaintBackground(Canvas: TCanvas; const Rect: TRect); virtual;
    procedure Paint; override;
    procedure Prepare;
    procedure Unprepare;
    procedure Animate;
    procedure UpdateMedia;
    procedure AdjustClientSize;
    procedure CalculatePicRect;
    procedure InvalidateArea(Area: TRect);
    function WaitForThread: Boolean;
    procedure DoChange; virtual;
    procedure DoProgress; virtual;
    procedure DoCustomDraw(Picture, Screen: TBitmap); virtual;
    procedure DoBeforeNewFrame(Picture, Screen: TBitmap);  virtual;
    procedure DoAfterNewFrame(Picture, Screen: TBitmap);  virtual;
    procedure DoComplete; virtual;
    procedure DoStart(NewPicture, OldPicture: TBitmap); virtual;
    procedure DoStop; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute; virtual;
    procedure Stop; virtual;
    procedure Clear; virtual;
    property Busy: Boolean read fBusy;
    property Empty: Boolean read GetEmpty;
    property Progress: TPercent read fProgress write SetProgress;
  protected
    property AutoSize: Boolean read fAutoSize write SetAutoSize_ default True;
    property BgMode: TBackgroundMode read fBgMode write SetBgMode default bmTiled;
    property BgPicture: TPicture read fBgPicture write SetBgPicture;
    property Center: Boolean read fCenter write SetCenter default False;
    property Delay: Word read fDelay write fDelay default 40;
    property Manual: Boolean read fManual write SetManual default False;
    property OverDraw: Boolean read fOverDraw write fOverDraw default True;
    property Picture: TPicture read fPicture write SetPicture;
    property Reverse: Boolean read fReverse write fReverse default False;
    property Stretch: Boolean read fStretch write SetStretch default False;
    property StretchFine: Boolean read fStretchFine write SetStretchFine default False;
    property Step: Word read fStep write SetStep default 4;
    property Style: TShowStyle read fStyle write SetStyle default 51;
    property StyleName: String read GetStyleName write SetStyleName stored False;
    property Threaded: Boolean read fThreaded write fThreaded default True;
    property ThreadPriority: TThreadPriority read fThreadPriority write fThreadPriority default tpNormal;
    property OnAfterNewFrame: TCustomDrawEvent read fOnAfterNewFrame write fOnAfterNewFrame;
    property OnBeforeNewFrame: TCustomDrawEvent read fOnBeforeNewFrame write fOnBeforeNewFrame;
    property OnCustomDraw: TCustomDrawEvent read fOnCustomDraw write fOnCustomDraw;
    property OnChange: TNotifyEvent read fOnChange write fOnChange;
    property OnComplete: TNotifyEvent read fOnComplete write fOnComplete;
    property OnMouseEnter: TNotifyEvent read fOnMouseEnter write fOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read fOnMouseLeave write fOnMouseLeave;
    property OnProgress: TNotifyEvent read fOnProgress write fOnProgress;
    property OnStart: TCustomDrawEvent read fOnStart write fOnStart;
    property OnStop: TNotifyEvent read fOnStop write fOnStop;
  published
    property About: TAbout read fAbout write fAbout stored False;
  end;

{ TPicShow }

  TPicShow = class(TCustomPicShow)
  published
    property Align;
    {$IFDEF DELPHI4_UP}
    property Anchors;
    {$ENDIF}
    property AutoSize;
    property BgMode;
    property BgPicture;
    property Center;
    property Color;
    property Delay;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Height;
    property Manual;
    property OverDraw;
    property ParentColor;
    property ParentShowHint;
    property Picture;
    property PopupMenu;
    property ShowHint;
    property Reverse;
    property Stretch;
    property StretchFine;
    property Step;
    property Style;
    property StyleName;
    property TabOrder;
    property TabStop;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    property OnClick;
    property OnChange;
    property OnComplete;
    property OnCustomDraw;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnProgress;
    property OnStart;
    property OnStartDrag;
    property OnStop;
  end;

{ TDBPicShow }

  TGetGraphicClassEvent = procedure(Sender: TObject;
    var GraphicClass: TGraphicClass) of object;

  TDBPicShow = class(TCustomPicShow)
  private
    fOnAfterLoadPicture: TNotifyEvent;
    fOnBeforeLoadPicture: TNotifyEvent;
    fOnGetGraphicClass: TGetGraphicClassEvent;
    fDataLink: TFieldDataLink;
    fAutoDisplay: Boolean;
    fModified: Boolean;
    fLoaded: Boolean;
    fSkipLoading: Boolean;
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    procedure SetAutoDisplay(Value: Boolean);
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetReadOnly(Value: Boolean);
    procedure UpdateData(Sender: TObject);
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure DoChange; override;
    function FindGraphicClass(Stream: TMemoryStream): TGraphicClass; virtual;
    procedure LoadPictureFromStream(Stream: TMemoryStream;
      GraphicClass: TGraphicClass); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadPicture;
    property Field: TField read GetField;
    property Picture;
  published
    property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
    property Align;
    {$IFDEF DELPHI4_UP}
    property Anchors;
    {$ENDIF}
    property AutoSize;
    property BgMode;
    property BgPicture;
    property Center;
    property Color;
    property Delay;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Height;
    property Manual;
    property OverDraw;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Reverse;
    property Stretch;
    property StretchFine;
    property Step;
    property Style;
    property StyleName;
    property TabOrder;
    property TabStop;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    property OnClick;
    property OnComplete;
    property OnCustomDraw;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnProgress;
    property OnStart;
    property OnStartDrag;
    property OnStop;
    property OnAfterLoadPicture: TNotifyEvent read fOnAfterLoadPicture write fOnAfterLoadPicture;
    property OnBeforeLoadPicture: TNotifyEvent read fOnBeforeLoadPicture write fOnBeforeLoadPicture;
    property OnGetGraphicClass: TGetGraphicClassEvent read fOnGetGraphicClass write fOnGetGraphicClass;
  end;

implementation

{ Graphic Format Signatures }

type
  TGraphicSign = record
    GraphicClass: TGraphicClass;
    Offset, Length: DWORD;
    Signature: PChar;
  end;

const
  GraphicSigns: array[1..4] of TGraphicSign = (
    (GraphicClass: TBitmap;     Offset: 0;  Length: 2;  Signature: #$42#$47),          // BMP
    (GraphicClass: TJPEGImage;  Offset: 6;  Length: 4;  Signature: #$4A#$46#$49#$46),  // JPG
    (GraphicClass: TMetafile;   Offset: 0;  Length: 4;  Signature: #$D7#$CD#$C6#$9A),  // WMF
    (GraphicClass: TMetafile;   Offset: 41; Length: 3;  Signature: #$45#$4D#$46)       // EMF
//  (GraphicClass: TGIFImage;   Offset: 0;  Length: 3;  Signature: #$47#$49#$46)       // GIF
  );

{ Helper Functions }

function ScaleImageToRect(const IR, R: TRect): TRect;
var
  iW, iH: Integer;
  rW, rH: Integer;
begin
  iW := IR.Right - IR.Left;
  iH := IR.Bottom - IR.Top;
  rW := R.Right - R.Left;
  rH := R.Bottom - R.Top;
  if (rW / iW) < (rH / iH) then
  begin
    iH := MulDiv(iH, rW, iW);
    iW := rW;
  end
  else
  begin
    iW := MulDiv(iW, rH, iH);
    iH := rH;
  end;
  SetRect(Result, 0, 0, iW, iH);
  OffsetRect(Result, R.Left + (rW - iW) div 2, R.Top + (rH - iH) div 2);
end;

procedure DrawTiledImage(Canvas: TCanvas; const Rect: TRect; G: TGraphic);
var
  R, Rows, C, Cols: Integer;
begin
  if (G <> nil) and (not G.Empty) then
  begin
    Rows := ((Rect.Bottom - Rect.Top) div G.Height) + 1;
    Cols := ((Rect.Right - Rect.Left) div G.Width) + 1;
    for R := 1 to Rows do
      for C := 1 to Cols do
        Canvas.Draw(Rect.Left + (C-1) * G.Width, Rect.Top + (R-1) * G.Height, G)
  end;
end;

{$IFNDEF DELPHI5_UP}
// This procedure is copied from Delphi 5 SysUtils uint
procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;  // clear the reference before destroying the object
  P.Free;
end;
{$ENDIF}

{ TAnimateThread }

type
  TAnimateThread = class(TThread)
  private
    fExecuted: Boolean;
    PicShow: TCustomPicShow;
    procedure UpdateProgress;
  protected
    constructor Create(APicShow: TCustomPicShow);
    procedure Execute; override;
    property Executed: Boolean read fExecuted;
  end;

constructor TAnimateThread.Create(APicShow: TCustomPicShow);
begin
  inherited Create(True);
  PicShow := APicShow;
  Priority := PicShow.ThreadPriority;
  Resume;
end;

procedure TAnimateThread.Execute;
var
  StartTime: DWord;
  Delay: Integer;
begin
  fExecuted := True;
  try
    while not Terminated do
    begin
      StartTime := GetTickCount;
      UpdateProgress;