picshow.pas

免费控件PicShow的最新版本

{------------------------------------------------------------------------------}
{                                                                              }
{  PicShow v4.04                                                               }
{  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.                                     }
{    :: Hertwig van Zwietering <[e-mail]> for the exact       }
{       timing code.                                                           }
{    :: Nest King <[e-mail]> for Exif JPEG signature.                }
{                                                                              }
{------------------------------------------------------------------------------}

{$I DELPHIAREA.INC}
{$R-,Q-,O+}

// If you have the GraphicEx library (http://www.lischke-online.de), by enabling
// the following directive, DBPicShow uses the GraphicEx library to detect image
// format of the blob fields. Otherwise, DBPicShow can only detect Bitmap, JPEG,
// and Metafile image formats, and for other image formats you have to provide a
// handler to OnGetGraphicClass event. 
{.$DEFINE GRAPHICEX}


unit PicShow;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, DB, DBCtrls, 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);

  {$IFNDEF DELPHI4_UP}
  TBorderWidth = 0..MaxInt;
  {$ENDIF}

{ TCustomPicShow }

  TCustomPicShow = class(TCustomControl)
  private
    fAbout: TAbout;
    fPicture: TPicture;
    fBgPicture: TPicture;
    fBgMode: TBackgroundMode;
    fFrameColor: TColor;
    fFrameWidth: TBorderWidth;
    {$IFNDEF DELPHI4_UP}
    fAutoSize: Boolean;
    {$ENDIF}
    fCenter: Boolean;
    fStretch: Boolean;
    fProportional: Boolean;
    fOverDraw: Boolean;
    fThreaded: Boolean;
    fThreadPriority: TThreadPriority;
    fManual: Boolean;
    fStyle: TShowStyle;
    fStep: Word;
    fDelay: Word;
    fProgress: TPercent;
    fReverse: Boolean;
    fBusy: Boolean;
    fExactTiming: Boolean;
    fOnChange: TNotifyEvent;
    fOnProgress: TNotifyEvent;
    fOnComplete: TNotifyEvent;
    fOnCustomDraw: TCustomDrawEvent;
    fOnMouseEnter: TNotifyEvent;
    fOnMouseLeave: TNotifyEvent;
    fOnBeforeNewFrame: TCustomDrawEvent;
    fOnAfterNewFrame: TCustomDrawEvent;
    fOnStart: TCustomDrawEvent;
    fOnStop: TNotifyEvent;
    Display: TBitmap;
    DisplayRect: TRect;
    PicRect: TRect;
    Thread: TThread;
    Stopping: Boolean;
    Drawing: Boolean;
    DynamicOldPic: Boolean;
    OldPic: TBitmap;
    Pic: TBitmap;
    CS: TRTLCriticalSection;
    procedure SetPicture(Value: TPicture);
    procedure SetBgPicture(Value: TPicture);
    procedure SetBgMode(Value: TBackgroundMode);
    procedure SetFrameColor(Value: TColor);
    procedure SetFrameWidth(Value: TBorderWidth);
    {$IFNDEF DELPHI4_UP}
    procedure SetAutoSize(Value: Boolean);
    {$ENDIF}
    procedure SetCenter(Value: Boolean);
    procedure SetStretch(Value: Boolean);
    procedure SetProportional(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 WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure ThreadTerminated(var Msg: TMessage); message PS_THREADTERMINATED;
    procedure ReadStretchFine(Reader: TReader); // Obsolete Property
  protected
    procedure DefineProperties(Filer: TFiler); override;
    {$IFDEF DELPHI4_UP}
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    {$ELSE}
    procedure AdjustSize;
    {$ENDIF}
    procedure Paint; override;
    procedure Prepare;
    procedure Unprepare;
    procedure Animate;
    procedure DrawBackground(Canvas: TCanvas; const Rect: TRect); virtual;
    procedure Draw(Canvas: TCanvas); virtual;
    function UpdateProgress(ProgressStep: Integer; out ElapsedTime: Integer): Boolean;
    procedure UpdateDisplay;
    procedure UpdateDisplayRect;
    procedure UpdateOldPic;
    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;
    function GetStyleNames(Names: TStrings): Integer;
    property Busy: Boolean read fBusy;
    property Empty: Boolean read GetEmpty;
    property Progress: TPercent read fProgress write SetProgress;
  protected
    {$IFNDEF DELPHI4_UP}
    property AutoSize: Boolean read fAutoSize write SetAutoSize default False;
    {$ENDIF}
    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 ExactTiming: Boolean read fExactTiming write fExactTiming default False;
    property FrameColor: TColor read fFrameColor write SetFrameColor default clActiveBorder;
    property FrameWidth: TBorderWidth read fFrameWidth write SetFrameWidth default 0;
    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 Proportional: Boolean read fProportional write SetProportional 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;
    {$IFDEF DELPHI4_UP}
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind;
    property BevelWidth;
    {$ENDIF}
    property BgMode;
    property BgPicture;
    {$IFDEF DELPHI4_UP}
    property BorderWidth;
    {$ENDIF}
    property Center;
    property Color;
    {$IFDEF DELPHI4_UP}
    property Constraints;
    {$ENDIF}
    property Delay;
    {$IFDEF DELPHI4_UP}
    property DockSite;
    {$ENDIF}
    property DragCursor;
    {$IFDEF DELPHI4_UP}
    property DragKind;
    {$ENDIF}
    property DragMode;
    property Enabled;
    property ExactTiming;
    property FrameColor;
    property FrameWidth;
    property Height;
    property Manual;
    property OverDraw;
    property ParentColor;
    property ParentShowHint;
    property Picture;
    property PopupMenu;
    property Proportional;
    property ShowHint;
    property Reverse;
    property Stretch;
    property Step;
    property Style;
    property StyleName;
    property TabOrder;
    property TabStop;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    {$IFDEF DELPHI4_UP}
    property OnCanResize;
    {$ENDIF}
    property OnClick;
    property OnChange;
    property OnComplete;
    {$IFDEF DELPHI4_UP}
    property OnConstrainedResize;
    {$ENDIF}
    property OnCustomDraw;
    property OnDblClick;
    {$IFDEF DELPHI4_UP}
    property OnDockDrop;
    property OnDockOver;
    {$ENDIF}
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF DELPHI4_UP}
    property OnEndDock;
    {$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnProgress;
    {$IFDEF DELPHI4_UP}
    property OnResize;
    {$ENDIF}
    property OnStart;
    {$IFDEF DELPHI4_UP}
    property OnStartDock;
    {$ENDIF}
    property OnStartDrag;
    property OnStop;
    {$IFDEF DELPHI4_UP}
    property OnUnDock;
    {$ENDIF}
  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;
    {$IFDEF DELPHI4_UP}
    property BevelEdges;
    property BevelInner;
    property BevelOuter;
    property BevelKind;
    property BevelWidth;
    {$ENDIF}
    property BgMode;
    property BgPicture;
    {$IFDEF DELPHI4_UP}
    property BorderWidth;
    {$ENDIF}
    property Center;
    property Color;
    {$IFDEF DELPHI4_UP}
    property Constraints;
    {$ENDIF}
    property Delay;
    {$IFDEF DELPHI4_UP}
    property DockSite;
    property DragKind;
    {$ENDIF}
    property DragCursor;
    property DragMode;
    property Enabled;
    property ExactTiming;
    property FrameColor;
    property FrameWidth;
    property Height;
    property Manual;
    property OverDraw;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property Proportional;
    property ShowHint;
    property Reverse;
    property Stretch;
    property Step;
    property Style;
    property StyleName;
    property TabOrder;
    property TabStop;
    property Threaded;
    property ThreadPriority;
    property Visible;
    property Width;
    property OnAfterLoadPicture: TNotifyEvent read fOnAfterLoadPicture write fOnAfterLoadPicture;
    property OnAfterNewFrame;
    property OnBeforeNewFrame;
    property OnBeforeLoadPicture: TNotifyEvent read fOnBeforeLoadPicture write fOnBeforeLoadPicture;
    {$IFDEF DELPHI4_UP}
    property OnCanResize;
    {$ENDIF}
    property OnClick;
    {$IFDEF DELPHI4_UP}
    property OnConstrainedResize;
    {$ENDIF}
    property OnComplete;
    property OnCustomDraw;
    property OnDblClick;
    {$IFDEF DELPHI4_UP}
    property OnDockDrop;
    property OnDockOver;
    {$ENDIF}
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF DELPHI4_UP}
    property OnEndDock;
    {$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetGraphicClass: TGetGraphicClassEvent read fOnGetGraphicClass write fOnGetGraphicClass;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnProgress;
    {$IFDEF DELPHI4_UP}
    property OnResize;
    {$ENDIF}
    property OnStart;
    {$IFDEF DELPHI4_UP}
    property OnStartDock;
    {$ENDIF}
    property OnStartDrag;
    property OnStop;
    {$IFDEF DELPHI4_UP}
    property OnUnDock;
    {$ENDIF}
  end;

procedure DrawTile(Canvas: TCanvas; const Rect: TRect; Graphic: TGraphic);

implementation

uses
  JPEG {$IFDEF DELPHI6_UP}, Types {$ENDIF} {$IFDEF GRAPHICEX}, GraphicEx{$ENDIF};

{ Graphic Format Signatures }

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

const
  GraphicSigns: array[1..5] of TGraphicSign = (
    (GraphicClass: TBitmap;     Offset: 0;  Length: 2;  Signature: 'BM'),               // BMP
    (GraphicClass: TJPEGImage;  Offset: 6;  Length: 4;  Signature: 'JFIF'),             // JPG
    (GraphicClass: TJPEGImage;  Offset: 6;  Length: 4;  Signature: 'Exif'),             // JPG
    (GraphicClass: TMetafile;   Offset: 41; Length: 3;  Signature: 'EMF'),              // EMF
    (GraphicClass: TMetafile;   Offset: 0;  Length: 4;  Signature: #$D7#$CD#$C6#$9A)    // WMF
  );

{ Helper Functions }

procedure DrawTile(Canvas: TCanvas; const Rect: TRect; Graphic: TGraphic);
var
  DC: HDC;
  WR, R: TRect;
  W, H: Integer;
  SavedDC: Integer;
begin
  W := Graphic.Width;
  H := Graphic.Height;
  DC := Canvas.Handle;
  SavedDC := SaveDC(DC);
  try
    IntersectClipRect(DC, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    // Calculates actual visible bounds
    GetClipBox(DC, WR);
    Dec(WR.Left, (WR.Left - Rect.Left) mod W);
    Dec(WR.Top, (WR.Top - Rect.Top) mod H);
    // Draws the tiles
    R.Top := WR.Top;
    R.Bottom := R.Top + H;
    while R.Top < WR.Bottom do
    begin
      R.Left := WR.Left;
      R.Right := R.Left + W;
      while R.Left < WR.Right do
      begin
        if RectVisible(DC, R) then
          Canvas.StretchDraw(R, Graphic);
        Inc(R.Left, W);
        Inc(R.Right, W);
      end;
      Inc(R.Top, H);
      Inc(R.Bottom, H);
    end;
  finally
    RestoreDC(DC, SavedDC);
  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}