fcimager.pas

一套及时通讯的原码

unit fcImager;
{
//
// Components : TfcImager
//
// Copyright (c) 1999 by Woll2Woll Software
// 4/21/99 - RSW - Added CopyToClipboard method
// 8/2/99 - Check if parent is nil in BitmapChange event.
// 9/27/2001-Added SetFocus,TabOrder, and OnEnter/OnExit events. (Only fired when focusable).
// 10/11/2001-Added ProportionalCenter Draw Style.
// 1/16/2002 - Not using gclassname in paint event.
// 3/14/2002 - Correct for painting in a grid when csPaintCopy State.
// 4/9/2002 - Made GetDrawRect public.
// 5/30/2001-PYW- Make certain parent's handle has already been allocated when invalidating parent.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  fcCommon, fcBitmap, fcChangeLink, db, dbctrls, stdctrls;

{$i fcIfDef.pas}

type
  TfcImagerDrawStyle = (dsNormal, dsCenter, dsStretch, dsTile, dsProportional, dsProportionalCenter);

  TfcBitmapOptions = class;

  TfcRotate = class(TPersistent)
  private
    FBitmapOptions: TfcBitmapOptions;

    FCenterX: Integer;
    FCenterY: Integer;
    FAngle: Integer;

    procedure SetAngle(Value: Integer);
    procedure SetCenterX(Value: Integer);
    procedure SetCenterY(Value: Integer);
  public
    constructor Create(BitmapOptions: TfcBitmapOptions);
  published
    property CenterX: Integer read FCenterX write SetCenterX;
    property CenterY: Integer read FCenterY write SetCenterY;
    property Angle: Integer read FAngle write SetAngle;
  end;

  TfcAlphaBlend = class(TPersistent)
  private
    FBitmapOptions: TfcBitmapOptions;

    FAmount: Byte;
    FBitmap: TfcBitmap;
    FChanging: Boolean;

    function GetTransparent: Boolean;
    procedure SetAmount(Value: Byte);
    procedure SetBitmap(Value: TfcBitmap);
    procedure SetTransparent(Value: Boolean);
  protected
    procedure BitmapChanged(Sender: TObject); virtual;
  public
    constructor Create(BitmapOptions: TfcBitmapOptions);
    destructor Destroy; override;
  published
    property Amount: Byte read FAmount write SetAmount;
    property Bitmap: TfcBitmap read FBitmap write SetBitmap;
    property Transparent: Boolean read GetTransparent write SetTransparent;
  end;

  TfcWave = class(TPersistent)
  private
    FBitmapOptions: TfcBitmapOptions;
    FXDiv, FYDiv, FRatio: Integer;
    FWrap: Boolean;

    procedure SetXDiv(Value: Integer);
    procedure SetYDiv(Value: Integer);
    procedure SetRatio(Value: Integer);
    procedure SetWrap(Value: Boolean);
  public
    constructor Create(BitmapOptions: TfcBitmapOptions);
  published
    property XDiv: Integer read FXDiv write SetXDiv;
    property YDiv: Integer read FYDiv write SetYDiv;
    property Ratio: Integer read FRatio write SetRatio;
    property Wrap: Boolean read FWrap write SetWrap;
  end;

  TfcBitmapOptions = class(TPersistent)
  private
    FComponent: TComponent;

    FAlphaBlend: TfcAlphaBlend;
    FColor: TColor;
    FContrast: Integer;
    FEmbossed: Boolean;
    FTintColor: TColor;
    FGaussianBlur: Integer;
    FGrayScale: Boolean;
    FHorizontallyFlipped: Boolean;
    FInverted: Boolean;
    FLightness: Integer;
    FRotation: TfcRotate;
    FSaturation: Integer;
    FSharpen: Integer;
    FSponge: Integer;
    FTile: Boolean;
    FVerticallyFlipped: Boolean;
    FWave: TfcWave;

    FOnChange: TNotifyEvent;
    FOrigPicture: TPicture;
    FDestBitmap: TfcBitmap;
    FUpdateLock: Integer;

    // Property Access methods;
    procedure SetColor(Value: TColor);
    procedure SetBooleanProperty(Index: Integer; Value: Boolean);
    procedure SetTintColor(Value: TColor);
    procedure SetIntegralProperty(Index: Integer; Value: Integer);
  public
    constructor Create(AComponent: TComponent);
    destructor Destroy; override;

    procedure BeginUpdate; virtual;
    procedure Changed; virtual;
    procedure EndUpdate;

    property DestBitmap: TfcBitmap read FDestBitmap write FDestBitmap;
    property OrigPicture: TPicture read FOrigPicture write FOrigPicture;
    property Tile: Boolean read FTile write FTile;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  published
    property AlphaBlend: TfcAlphaBlend read FAlphaBlend write FAlphaBlend;
    property Color: TColor read FColor write SetColor;
    property Contrast: Integer index 4 read FContrast write SetIntegralProperty;
    property Embossed: Boolean index 0 read FEmbossed write SetBooleanProperty;
    property TintColor: TColor read FTintColor write SetTintColor;
    property GaussianBlur: Integer index 3 read FGaussianBlur write SetIntegralProperty;
    property GrayScale: Boolean index 2 read FGrayScale write SetBooleanProperty;
    property HorizontallyFlipped: Boolean index 3 read FHorizontallyFlipped write SetBooleanProperty;
    property Inverted: Boolean index 1 read FInverted write SetBooleanProperty;
    property Lightness: Integer index 0 read FLightness write SetIntegralProperty;
    property Rotation: TfcRotate read FRotation write FRotation;
    property Saturation: Integer index 1 read FSaturation write SetIntegralProperty;
    property Sharpen: Integer index 5 read FSharpen write SetIntegralProperty;
    property Sponge: Integer index 2 read FSponge write SetIntegralProperty;
    property VerticallyFlipped: Boolean index 4 read FVerticallyFlipped write SetBooleanProperty;
    property Wave: TfcWave read FWave write FWave;
  end;

  TfcCustomImager = class(TGraphicControl)
  private
    { Private declarations }
    FAutoSize: Boolean;
    FBitmapOptions: TfcBitmapOptions;
    FDrawStyle: TfcImagerDrawStyle;
    FEraseBackground: Boolean;
    FPreProcess: Boolean;
    FWorkBitmap: TfcBitmap;
    FPicture: TPicture;
    FChangeLinks: TList;
    FRespectPalette: boolean;
    FTransparent: boolean;  // Keep track in component instead of in picture
                            // This helps databound case support transparency
    FWinControl: TWinControl;
    FOnEnter: TNotifyEvent;
    FOnExit: TNotifyEvent;
    FFocusable: boolean;
    FOnKeyPress: TKeyPressEvent;
    FOnKeyDown, FOnKeyUp: TKeyEvent;
    FTabStop: boolean;
    FTabOrder: Integer;
    FFocused: boolean;
    FShowFocusRect: boolean;

    procedure SetTabStop(value: boolean);
    procedure SetTabOrder(value: integer);
    function GetRespectPalette: Boolean;
    function GetSmoothStretching: Boolean;
    function GetTransparent: Boolean;
    function GetTransparentColor: TColor;
    {$ifndef fcDelphi6Up}
    procedure SetAutoSize(Value: Boolean);
    {$endif}
    procedure SetDrawStyle(Value: TfcImagerDrawStyle);
    procedure SetEraseBackground(Value: Boolean);
    procedure SetPreProcess(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetRespectPalette(Value: Boolean);
    procedure SetSmoothStretching(Value: Boolean);
    procedure SetShowFocusRect(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    procedure NotifyChanges;
    procedure SetFocusable(Value: boolean);
  protected
    {$ifdef fcDelphi6Up}
    procedure SetAutoSize(Value: Boolean); override;
    {$endif}
    Function CreateImagerWinControl: TWinControl; virtual;
    procedure SetParent(Value: TWinControl); override;
    procedure BitmapOptionsChange(Sender: TObject); virtual;
    procedure BitmapChange(Sender: TObject); virtual;
    procedure UpdateAutoSize; virtual;

    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; override;
    procedure WndProc(var Message: TMessage); override;

    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;
    procedure KeyPress(var Key: Char); virtual;
    procedure DoEnter; virtual;
    procedure DoExit; virtual;

    property EraseBackground: Boolean read FEraseBackground write SetEraseBackground default True;
    property Focused: Boolean read FFocused;
  public
    UpdatingAutoSize: Boolean;
    InSetBounds: boolean;
    Patch: Variant;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function PictureEmpty: Boolean; virtual;
    procedure Invalidate; override;
    procedure RegisterChanges(ChangeLink: TfcChangeLink); virtual;
    procedure Resized; virtual;
    procedure UpdateWorkBitmap; virtual;
    procedure UnRegisterChanges(ChangeLink: TfcChangeLink); virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure CopyToClipboard; virtual;
    procedure PasteFromClipboard; virtual;
    procedure CutToClipboard; virtual;
    procedure SetFocus; virtual;
    function GetColorAtPoint(X,Y:Integer):TColor;
    function GetDrawRect: TRect;

    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize;
    property BitmapOptions: TfcBitmapOptions read FBitmapOptions write FBitmapOptions;
    property DrawStyle: TfcImagerDrawStyle read FDrawStyle write SetDrawStyle;
    property PreProcess: Boolean read FPreProcess write SetPreProcess;
    property Picture: TPicture read FPicture write SetPicture;
    property RespectPalette: Boolean read GetRespectPalette write SetRespectPalette default True;
    property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default False;
    property SmoothStretching: Boolean read GetSmoothStretching write SetSmoothStretching;
    property Transparent: Boolean read GetTransparent write SetTransparent;
    property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;
    property WorkBitmap: TfcBitmap read FWorkBitmap;
    property Focusable: boolean read FFocusable write SetFocusable default False;
    property TabOrder: integer read FTabOrder write SetTabOrder;
    property TabStop: boolean read FTabStop write SetTabStop default False;
    property OnKeyPress : TKeyPressEvent read FOnKeyPress write FOnKeyPress;
    property OnKeyDown : TKeyEvent read FOnKeyDown write FOnKeyDown;
    property OnKeyUp : TKeyEvent read FOnKeyUp write FOnKeyUp;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
  end;

  TfcImager = class(TfcCustomImager)
  published
    { Published declarations }
    property Align;
    property AutoSize;
    property BitmapOptions;
    property DrawStyle;
    property Picture;
    property PreProcess;
    property RespectPalette;
    property SmoothStretching;
    property Transparent;
    property TransparentColor;
    property Visible;
    property Focusable;

    property Anchors;
    property Constraints;
    property OnEndDock;
    property OnStartDock;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property TabOrder;
    property TabStop;
    property OnKeyPress;
    property OnKeyDown;
    property OnKeyUp;
  end;


  TfcDBCustomImager = class(TCustomControl)
  private
    { Private declarations }
    FAutoSize: Boolean;
    FBitmapOptions: TfcBitmapOptions;
    FDrawStyle: TfcImagerDrawStyle;
    FPreProcess: Boolean;
    FWorkBitmap: TfcBitmap;
    FPicture: TPicture;
    FChangeLinks: TList;
    FRespectPalette: boolean;
    FTransparent: boolean;  // Keep track in component instead of in picture
                            // This helps databound case support transparency
    FInResized:boolean;

    function GetRespectPalette: Boolean;
    function GetSmoothStretching: Boolean;
    function GetTransparent: Boolean;
    function GetTransparentColor: TColor;
    {$ifndef fcDelphi6Up}
    procedure SetAutoSize(Value: Boolean);
    {$endif}
    procedure SetDrawStyle(Value: TfcImagerDrawStyle);
    procedure SetPreProcess(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetRespectPalette(Value: Boolean);
    procedure SetSmoothStretching(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    function GetDrawRect: TRect;
    procedure NotifyChanges;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBkgnd;
  protected
    {$ifdef fcDelphi6Up}
    procedure SetAutoSize(Value: Boolean); override;
    {$endif}
    procedure BitmapOptionsChange(Sender: TObject); virtual;
    procedure BitmapChange(Sender: TObject); virtual;
    procedure UpdateAutoSize; virtual;

    procedure Loaded; override;
    procedure Paint; override;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CreateWnd; override;
  public
    UpdatingAutoSize: Boolean;
    InSetBounds: boolean;
    Patch: Variant;

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function PictureEmpty: Boolean; virtual;
    function GetColorAtPoint(X,Y:Integer):TColor;
    procedure Invalidate; override;
    procedure RegisterChanges(ChangeLink: TfcChangeLink); virtual;
    procedure Resized; virtual;
    procedure UpdateWorkBitmap; virtual;
    procedure UnRegisterChanges(ChangeLink: TfcChangeLink); virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize;
    property BitmapOptions: TfcBitmapOptions read FBitmapOptions write FBitmapOptions;
    property DrawStyle: TfcImagerDrawStyle read FDrawStyle write SetDrawStyle;
    property PreProcess: Boolean read FPreProcess write SetPreProcess;
    property Picture: TPicture read FPicture write SetPicture;
    property RespectPalette: Boolean read GetRespectPalette write SetRespectPalette default True;
    property SmoothStretching: Boolean read GetSmoothStretching write SetSmoothStretching;
    property Transparent: Boolean read GetTransparent write SetTransparent;
    property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;

    property WorkBitmap: TfcBitmap read FWorkBitmap;
  end;

  TfcImagerPictureType = (fcptBitmap,fcptJpg,fcptMetafile,fcptIcon);
  type TfcDBImager=class;

  TfcCalcPictureTypeEvent =
    procedure (ImageControl:TfcDBImager;var PictureType:TfcImagerPictureType;var GraphicClassName:String) of object;

  TfcDBImager = class(TfcDBCustomImager)
  private
    FDataLink: TFieldDataLink;
    FPictureLoaded: boolean;
    FAutoDisplay: Boolean;
    FBorderStyle: TBorderStyle;
    FPictureType:TfcImagerPictureType;
    FOnCalcPictureType: TfcCalcPictureTypeEvent;

    procedure SetPictureType(Value:TfcImagerPictureType);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
    procedure DataChange(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure UpdateData(Sender: TObject);
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetAutoDisplay(Value: Boolean);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBkgnd;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure LoadPicture; virtual;

    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure DoExit; override;
    procedure Paint; override;
    procedure BitmapChange(Sender: TObject); override;
    function GetPalette: HPALETTE; override;
    function PaletteChanged(Foreground: Boolean): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyToClipboard; virtual;
    procedure PasteFromClipboard; virtual;
    procedure CutToClipboard; virtual;
    procedure DoCalcPictureType(var PictureType:TfcImagerPictureType;var GraphicClassName:String); virtual;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function UpdateAction(Action: TBasicAction): Boolean; override;

    property Field: TField read GetField;

  published
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
    property Ctl3D;
    property Color default clWindow;