picshow.pas

提供 122 种不同图形显示特效的可视构件

unit PicShow;

{

 TCustomPicShow v2.4
 by Kambiz R. Khojasteh

 email: [e-mail]
 web: http://www.crosswinds.net/~khojasteh/

 This component is freeware and may be used in any software
 product (free or commercial) under the condition that I'm
 given proper credit (title, name and e-mail address in the
 documentation or the About box of the product this component
 is used in).

 Thanks to M. R. Zamani for adding 8 effects.
 email: [e-mail]

 Special thanks to:
   [e-mail]
   Douglass Titjan ([e-mail])
   Jerry McLain ([e-mail])

}

// If you want to use TCustomPicShow as a windowed control,
// define the following symbol.
{.$DEFINE WINCONTROL}

{$IFNDEF VER80} { Delphi 1.0 }
  {$IFNDEF VER90} { Delphi 2.0 }
    {$IFNDEF VER100} { Delphi 3.0 }
       {$DEFINE PS_D4orHigher}
    {$ENDIF}
  {$ENDIF}
{$ENDIF}

interface

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

const
  RegionStyles = [0, 58..117];

type

  {$IFNDEF PS_D4orHigher}
  HRgn = THandle;
  {$ENDIF}

  TShowStyle = 0..122;
  TPercent = 0..100;
  TBackgroundMode = (bmNone, bmTiled, bmStretched, bmCentered);

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

  TAbout = class(TObject);

{ TCustomPicShow }

  TCustomPicShow = class({$IFDEF WINCONTROL}TCustomControl{$ELSE}TGraphicControl{$ENDIF})
  private
    fAbout: TAbout;
    fPicture: TPicture;
    fBgPicture: TPicture;
    fBgMode: TBackgroundMode;
    fAutoSize: Boolean;
    fCenter: Boolean;
    fStretch: Boolean;
    fStretchFine: 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;
    Media: TBitmap;
    PicRect: TRect;
    Thread: TThread;
    Drawing: Boolean;
    OffScreen: TBitmap;
    Stopping: Boolean;
    OldPic: TBitmap;
    Pic: TBitmap;
    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);
    function GetEmpty: Boolean;
    procedure AnimationComplete(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 AdjustClientSize;
    procedure CalculatePicRect;
    procedure InvalidateArea(Area: TRect);
    procedure Prepare;
    procedure Animate;
    procedure UpdateDisplay;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Stop;
    procedure Clear;
    property Busy: Boolean read fBusy;
    property Empty: Boolean read GetEmpty;
    property Progress: TPercent read fProgress write SetProgress;
  protected
    procedure Paint; override;
    procedure PictureChange(Sender: TObject); dynamic;
    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 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 fStyle default 51;
    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;
  published
    property About: TAbout read fAbout write fAbout stored False;
  end;

{ TPicShow }

  TPicShow = class(TCustomPicShow)
  published
    property Align;
    {$IFDEF PS_D4orHigher}
    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 ParentColor;
    property ParentShowHint;
    property Picture;
    property PopupMenu;
    property ShowHint;
    property Reverse;
    property Stretch;
    property StretchFine;
    property Step;
    property Style;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    property OnClick;
    property OnCustomDraw;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnChange;
    property OnComplete;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress;
    property OnStartDrag;
  end;

{ TDBPicShow }

  TDBPicShow = class(TCustomPicShow)
  private
    fDataLink: TFieldDataLink;
    fAutoDisplay: Boolean;
    fPictureLoaded: Boolean;
    procedure DataChange(Sender: TObject);
    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 CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure PictureChange(Sender: TObject); override;
  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 PS_D4orHigher}
    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 ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Reverse;
    property Stretch;
    property StretchFine;
    property Step;
    property Style;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    property OnClick;
    property OnCustomDraw;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnComplete;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress;
    property OnStartDrag;
  end;

function CreateTriangleRgn(x1, y1, x2, y2, x3, y3: Integer): HRgn;
function ScaleImageToRect(IR, R: TRect): TRect;
procedure DrawTiledImage(Canvas: TCanvas; Rect: TRect; G: TGraphic);
procedure MirrorCopyRect(Canvas: TCanvas; dstRect: TRect;
  Bitmap: TBitmap; srcRect: TRect; Horz, Vert: Boolean);
procedure MergeTransparent(dstBitmap, srcBitmap: TBitmap; Transparency: TPercent);
procedure MergeRotate(dstBitmap, srcBitmap: TBitmap; xOrg, yOrg: Integer; Angle: Double);

implementation

uses
  Math;

const
  MaxPixelCount = 32768;

type

  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..MaxPixelCount] of TRGBTriple;

  TAnimateThread = class(TThread)
  private
    PicShow: TCustomPicShow;
    procedure Update;
  public
    constructor Create(APicShow: TCustomPicShow);
    procedure Execute; override;
  end;

{ Miscellaneous routines }

function CreateBarRgn(X, Y, W, H, S: Integer; XMode, YMode: Byte): HRgn;
var
  X1, Y1: Integer;
  Rgn, tRgn: HRgn;
begin
  Result := NULLREGION;
  Rgn := NULLREGION;
  if X <= W then Y1 := 0 else Y1 := 5;
  while Y1 < H + 5 do
  begin
    if X > W then
    begin
      tRgn := CreateRectRgn(0, Y1 - 5, W, Y1);
      if XMode in [1, 4] then
        Rgn := CreateRectRgn(2 * W - X, Y1, W, Y1 + 5)
      else if XMode in [2, 5] then
        Rgn := CreateRectRgn(0, Y1, X - W, Y1 + 5);
      CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
      DeleteObject(tRgn);
    end
    else
    begin
      if (X + S) > W then X := W;
      if XMode in [1, 5] then
        Rgn := CreateRectRgn(W - X, Y1, W, Y1 + 5)
      else if XMode in [2, 4] then
        Rgn := CreateRectRgn(0, Y1, X, Y1 + 5)
      else if XMode = 3 then
      begin
        tRgn := CreateRectRgn(W - X, Y1, W, Y1 + 5);
        Rgn := CreateRectRgn(0, Y1 + 5, X, Y1 + 10);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end;
    end;
    if Result <> NULLREGION then
    begin
      CombineRgn(Result, Result, Rgn, RGN_OR);
      DeleteObject(Rgn);
    end
    else
      Result := Rgn;
    Inc(Y1, 10)
  end;
  if Y <= H then X1 := 0 else X1 := 5;
  while X1 < W + 5 do
  begin
    if Y > H then
    begin
      tRgn := CreateRectRgn(X1 - 5, 0, X1, H);
      if YMode in [1, 4] then
        Rgn := CreateRectRgn(X1, 2 * H - Y, X1 + 5, H)
      else if YMode in [2, 5] then
        Rgn := CreateRectRgn(X1, 0, X1 + 5, Y - H);
      CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
      DeleteObject(tRgn);
    end
    else
    begin
      if (Y + S) > H then Y := H;
      if YMode in [1, 5] then
        Rgn := CreateRectRgn(X1, H - Y, X1 + 5, H)
      else if YMode in [2, 4] then
        Rgn := CreateRectRgn(X1, 0, X1 + 5, Y)
      else if YMode = 3 then
      begin
        tRgn := CreateRectRgn(X1, H - Y, X1 + 5, H);
        Rgn := CreateRectRgn(X1 + 5, 0, X1 + 10, Y);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end;
    end;
    if Result <> NULLREGION then
    begin
      CombineRgn(Result, Result, Rgn, RGN_OR);
      DeleteObject(Rgn);
    end
    else
      Result := Rgn;
    Inc(X1, 10)
  end;
end;

function CreateSplashRgn(X, Y, W, H, XMode, YMode: Integer): HRgn;
var
  X1, Y1, N: Integer;
  Rgn, tRgn: HRgn;
begin
  Result := NULLREGION;
  if XMode <> 0 then
  begin
    if X < W then
      N := W div 7
    else
      N := 0;
    Y1 := 0;
    while Y1 < H do
    begin
      if XMode = 1 then
        Rgn := CreateRectRgn(W - X + Random(N) - Random(N), Y1, W, Y1 + 5 + H mod 5)
      else if XMode = 2 then
        Rgn := CreateRectRgn(0, Y1, X + Random(N) - Random(N), Y1 + 5 + H mod 5)
      else if XMode = 3 then
      begin
        Rgn := CreateRectRgn((W - X + Random(N) - Random(N)) div 2, Y1, W div 2, Y1 + 5 + H mod 5);
        tRgn := CreateRectRgn(W div 2, Y1, (W + X + Random(N) - Random(N)) div 2, Y1 + 5 + H mod 5);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end
      else
      begin
        Rgn := CreateRectRgn(W - (X + Random(N) - Random(N)) div 2, Y1, W, Y1 + 5 + H mod 5);
        tRgn := CreateRectRgn(0, Y1, (X + Random(N) - Random(N)) div 2, Y1 + 5 + H mod 5);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end;
      if Result <> NULLREGION then
      begin
        CombineRgn(Result, Result, Rgn, RGN_OR);
        DeleteObject(Rgn);
      end
      else
        Result := Rgn;
      Inc(Y1, 5);
    end;
  end;
  if YMode <> 0 then
  begin
    if Y < H then
      N := H div 7
    else
      N := 0;
    X1 := 0;
    while X1 < W do
    begin
      if YMode = 1 then
        Rgn := CreateRectRgn(X1, H - Y + Random(N) - Random(N), X1 + 5 + W mod 5, H)
      else if YMode = 2 then
        Rgn := CreateRectRgn(X1, 0, X1 + 5 + W mod 5, Y + Random(N) - Random(N))
      else if YMode = 3 then
      begin
        Rgn := CreateRectRgn(X1, (H - Y + Random(N) - Random(N)) div 2, X1 + 5 + W mod 5, H div 2);
        tRgn := CreateRectRgn(X1, H div 2, X1 + 5 + W mod 5, (H + Y + Random(N) - Random(N)) div 2);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end
      else
      begin
        Rgn := CreateRectRgn(X1, H - (Y + Random(N) - Random(N)) div 2, X1 + 5 + W mod 5, H);
        tRgn := CreateRectRgn(X1, 0, X1 + 5 + W mod 5, (Y + Random(N) - Random(N)) div 2);
        CombineRgn(Rgn, Rgn, tRgn, RGN_OR);
        DeleteObject(tRgn);
      end;
      if Result <> NULLREGION then
      begin
        CombineRgn(Result, Result, Rgn, RGN_OR);
        DeleteObject(Rgn);
      end