RealICQClient/Includes/FlatStyle/FlatSysex.pas

unit FlatSysex;

{$I FlatStyle.inc}

interface

uses
 Windows, Messages, Controls, Forms, SysUtils, DB, DBCtrls, DBGrids,
 MMSystem, Classes, DBConsts, Grids, FlatExcfm, FlatUtils, Dialogs,
 Menus, Graphics, ShellApi, ExtCtrls, FlatWatet;

type
  //导出数据选项,
  //dmDefault为导出的数据默认为字段类型的数据,
  //dmString为导出的所有数据全部转换为字符类型
  TEduceType  = (dmDefault,dmString);
  TEduceMode  = (emDefault,emSingle);
  TEduceData  = class;
  TEduceDatas = class;
  TEduceLink  = class;
  { TDefineExcel }
  TDefineExcel  = Class(TVersionComponent)
  Private
    fCol        : word;
    fRow        : word;
    ExcelStream : TStream;
    FEduceType  : TEduceType;
    FColumns    : TEduceDatas;
    FUpdateLock : Byte;
    FLayoutLock : Byte;
    FDataLink   : TEduceLink;
    FLayoutSet  : Boolean;
    FEduceTitle : Boolean;
    FExcelForm  : TExcelForm;
    FInterval   : integer;
    FShowProgress: boolean;
    FFileName: String;
    FEduceMode: TEduceMode;
    FDefaultExt: String;
    function  GetFieldCount: Integer;
    function  GetDataSource: TDataSource;
    function  GetColumnCount: integer;
    function  GetEduceCount: integer;
    procedure SeTEduceType(const Value: TEduceType);
    procedure EndProgress;
    procedure StartProgress(Max: Integer);
    procedure SetColumns(const Value: TEduceDatas);
    procedure SetDataSource(const Value: TDataSource);
    procedure DefineFieldMap;
    function  GetFields(FieldIndex: Integer): TField;
    procedure SetDefaultExt(Value: String);
  protected
    // 以下是导出到 MS-Excel 操作过程
    procedure WriteData(Field: TField);
    procedure WriteTitle;
    procedure WriteBlankCell;
    procedure WriteFloatCell(const AValue: Double);
    procedure WriteIntegerCell(const AValue: Integer);
    procedure WriteStringCell(const AValue: string);
    procedure WritePrefix;
    procedure WriteSuffix;
    procedure WriteDataCells;
    procedure SaveExcel(Save: TStream);
    // 结束 MS-Excel 操作过程
    procedure BeginLayout;
    procedure EndLayout;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure LayoutChanged; virtual;
    procedure LinkActive(Value: Boolean); virtual;
    procedure CancelLayout;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadColumns(Reader: TReader);
    procedure WriteColumns(Writer: TWriter);
    procedure Loaded; override;
    procedure InitColumns;
    procedure IncColRow;
    function  CreateDataLink: TEduceLink; dynamic;
    function  CreateColumns: TEduceDatas;
    function  AcquireLayoutLock: Boolean;
    property  UpdateLock: Byte read FUpdateLock;
    property  LayoutLock: Byte read FLayoutLock;
    property  DataLink: TEduceLink read FDataLink;
    property  LayoutSet: Boolean read FLayoutSet write FLayoutSet;
    property  EduceType: TEduceType read FEduceType write SeTEduceType default dmDefault;
    property  EduceDatas: TEduceDatas read FColumns write SetColumns;
    property  DataSource: TDataSource read GetDataSource write SetDataSource;
    property  EduceTitle: Boolean read FEduceTitle write FEduceTitle default true;
    property  ExcelForm: TExcelForm read FExcelForm;
    property  Interval: integer read FInterval write FInterval default 500;
    property  ShowProgress: boolean read FShowProgress write FShowProgress default true;
    property  FileName: String read FFileName write FFileName;
    property  EduceMode: TEduceMode read FEduceMode write FEduceMode default emSingle;
    property  DefaultExt: String read FDefaultExt write SetDefaultExt;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExportAll;
    procedure ExecuteSave;

    procedure InitFields;
    procedure RestoreFields;
    procedure ClearFields;
    property  Fields[FieldIndex: Integer]: TField read GetFields;
    property  FieldCount: Integer read GetFieldCount;
    property  ColumnCount: integer read GetColumnCount;
    property  EduceCount: integer read GetEduceCount;
  end;
  { FlatExcel }
  TFlatExcel  = Class(TDefineExcel)
  published
    property  EduceType;
    property  EduceDatas stored False;
    property  DataSource;
    property  EduceTitle;
    property  Interval;
    property  ShowProgress;
    property  FileName;
    property  EduceMode;
    property  DefaultExt;
  end;
  { TEduceLink }
  TEduceLink = class(TDataLink)
  private
    FCells: TDefineExcel;
    FFieldCount: Integer;
    FFieldMap: array of Integer;
    FModified: Boolean;
    FSparseMap: Boolean;
    function GetDefaultFields: Boolean;
    function GetFields(I: Integer): TField;
  protected
    procedure ActiveChanged; override;
    procedure LayoutChanged; override;
    function  GetMappedIndex(ColIndex: Integer): Integer;
    function  IsAggRow(Value: Integer): Boolean; virtual;
  public
    constructor Create(ADSExcel: TDefineExcel);
    destructor Destroy; override;
    procedure ClearMapping;
    function AddMapping(const FieldName: string): Boolean;
    property DefaultFields: Boolean read GetDefaultFields;
    property FieldCount: Integer read FFieldCount;
    property Fields[I: Integer]: TField read GetFields;
    property SparseMap: Boolean read FSparseMap write FSparseMap;
    property Cells: TDefineExcel read FCells;
  end;
  { TEduceData }
  TEduceData = class(TCollectionItem)
  private
    FFieldName: string;
    FVisible: Boolean;
    FStored: Boolean;
    FCaption: String;
    FField: TField;
    procedure SetCaption(const Value: String);
    procedure SetField(Value: TField);
    function  GetField: TField;
    procedure SetFieldName(const Value: String);
    procedure SetVisible(const Value: Boolean);
  protected
    function  GetExcel: TDefineExcel;
    function  GetDisplayName: string; override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property  Cells: TDefineExcel read GetExcel;
    property  Field: TField read GetField write SetField;
    property  IsStored: Boolean read FStored write FStored default false;
  published
    property  Caption: string read fCaption write SetCaption;
    property  FieldName: String read fFieldName write SetFieldName;
    property  Visible: Boolean read FVisible write SetVisible;
  end;
  TEduceDataClass = class of TEduceData;
  TEduceDatasState = (csDefault, csCustomized);
  { TEduceDatas }
  TEduceDatas = class(TCollection)
  private
    FCells: TDefineExcel;
    function  GetColumn(Index: Integer): TEduceData;
    function  GetState: TEduceDatasState;
    procedure SetColumn(Index: Integer; Value: TEduceData);
    procedure SetState(NewState: TEduceDatasState);
  protected
    function  GetOwner: TPersistent; override;
    function  InternalAdd: TEduceData;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(DSExcel: TDefineExcel; ColumnClass: TEduceDataClass);
    procedure LoadFromFile(const Filename: string);
    procedure LoadFromStream(S: TStream);
    procedure RebuildColumns;
    procedure SaveToFile(const Filename: string);
    procedure SaveToStream(S: TStream);
    function  Add: TEduceData;
    property  State: TEduceDatasState read GetState write SetState;
    property  Cells: TDefineExcel read FCells;
    property  Items[Index: Integer]: TEduceData read GetColumn write SetColumn; default;
  end;
  { TFlatSound }
  TSoundEvent = (seBtnClick, seMenu, seMenuClick, seMoveIntoBtn, sePanelExpand);

  TFlatSound = class(TVersionComponent)
  private
    FEvent: TSoundEvent;
  public
    procedure Play;
    procedure PlayThis(ThisEvent: TSoundEvent);
    constructor Create(AOwner: TComponent); override;
  published
    property Event: TSoundEvent read FEvent write FEvent;
  end;

  { TFlatAnimWnd }
  TFlatAnimWnd = class;

  TFlatAnimHookWnd = class(TWinControl)
  private
    FAnimateWindow: TFlatAnimWnd;
    procedure WMCreate (var Message: TMessage); message WM_CREATE;
    procedure WMDestroy (var Message: TMessage); message WM_DESTROY;
  public
    constructor Create (AOwner: TComponent); override;
  end;

  TFlatAnimWnd = class(TVersionComponent)
  private
    FOwner: TComponent;
    FNewProc, FOldProc, FNewAppProc, FOldAppProc: TFarProc;
    FOnMinimize: TNotifyEvent;
    FOnRestore: TNotifyEvent;
    procedure NewWndProc (var Message: TMessage);
    procedure NewAppWndProc (var Message: TMessage);
    procedure MinimizeWnd;
    procedure RestoreWnd;
    procedure OwnerWndCreated;
    procedure OwnerWndDestroyed;
  protected
    FHookWnd: TFlatAnimHookWnd;
    procedure SetParentComponent(Value: TComponent); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Minimize;
  published
    property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
    property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
  end;

  { TDefineSingle }
  TDefineSingle = class(TVersionComponent)
  private
    { Private declarations }
    FActive: boolean;
    FCaption: string;
    FTitle: string;
    procedure SetActive(Value: boolean);
    procedure SetCaption(const Value: string);
    procedure SetTitle(const Value: string);
  protected
    { Protected declarations }
    procedure Loaded; override;
    procedure Run(State:Boolean; Title:String);
    property Active: boolean read FActive write SetActive default True;
    property Caption: string read FCaption write SetCaption;
    property Title: string read FTitle write SetTitle;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  end;

  TFlatSingle = class(TDefineSingle)
  published
    { Published declarations }
    property Active;
    property Caption;
    property Title;
  end;

  { TDefineTimer }
  TDefineTimer = class(TVersionComponent)
  private
    uTimerID: MMRESULT;
    FInterval: Cardinal;
    FPeriod: Cardinal;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
    procedure SetPeriod(Value: Cardinal); //设置分辨率
  protected
    procedure Timer; dynamic;
    procedure UpdateTimer;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property Period: Cardinal read FPeriod write SetPeriod default 10;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { TFlatTimer }
  TFlatTimer = class(TDefineTimer)
  published
    property Enabled;
    property Interval;
    property Period;
    property OnTimer;
  end;

  { TDefineTaskbarIcon }
  TDefineTaskbarMode = (thDefault,thCustom);
  TDefineTaskbarIcon = class(TVersionComponent)
  private
    FActive: Boolean;
    FHint: string;
    FIcon: TIcon;
    FHandle: HWnd;
    FOnClick: TNotifyEvent;
    FOnDblClick: TNotifyEvent;
    FOnRightClick: TNotifyEvent;
    FOnMouseMove: TNotifyEvent;
    FWMTaskbarCreated: UINT;
    FPopupMenu: TPopupMenu;
    FIconMode: TDefineTaskbarMode;
    FHintMode: TDefineTaskbarMode;
    //FOnMinimize: TNotifyEvent;
    //FOnRestore: TNotifyEvent;
    procedure SetActive(Value: Boolean);
    procedure SetHint(Value: string);
    procedure SetIcon(Value: TIcon);
    procedure SetPopupMenu(const Value: TPopupMenu);
    procedure SetHintMode(const Value: TDefineTaskbarMode);
    procedure SetIconMode(const Value: TDefineTaskbarMode);
  protected
    procedure PrivateWndProc(var Message: TMessage);
    procedure WndProc(var Message: TMessage); dynamic;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function AppHook(var Message: TMessage): Boolean;
    function AddIcon: Boolean; dynamic;
    function DeleteIcon: Boolean; dynamic;
    function ModifyIcon(Aspect: Integer): Boolean; dynamic;
    function DoIcon(Action: DWORD; Aspect: UINT): Boolean; dynamic;
    property Handle: HWnd read FHandle;
    property Active: Boolean read FActive write SetActive;
    property Hint: string read FHint write SetHint;
    property HintMode: TDefineTaskbarMode read FHintMode write SetHintMode default thDefault;
    property Icon: TIcon read FIcon write SetIcon;
    property IconMode: TDefineTaskbarMode read FIconMode write SetIconMode default thDefault;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnRightClick: TNotifyEvent read FOnRightClick write FOnRightClick;
    property OnMouseMove: TNotifyEvent read FOnMouseMove write FOnMouseMove;
    //property OnAppMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
    //property OnAppRestore: TNotifyEvent read FOnRestore write FOnRestore;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TFlatTaskbarIcon = class(TDefineTaskbarIcon)
  published
    property Active;
    property Hint;
    property HintMode;
    property Icon;
    property IconMode;
    property PopupMenu;
    property OnClick;
    property OnDblClick;
    property OnRightClick;
    property OnMouseMove;
    //property OnAppMinimize;
    //property OnAppRestore;
  end;

  { TDefineAnimation }
  TDefineAnimation = class(TVersionControl)
  private
    FTransparent: Boolean;
    FAnimation: TBitmap;
    FFrames: Integer;
    FFrameWidth: Integer;
    FFrame: Integer;
    FInterval: Integer;
    FTransColor: TColor;
    FActive: Boolean;
    FLoop: Boolean;
    FReverse: Boolean;
    FTimer: TTimer;
    FBorderColor: TColor;
    FBorder: Boolean;
    FFrameChange: TOnFrameChange;
    FAnimationLayout: TAnimationLayout;
    procedure SetAnimation(Value: TBitmap);
    procedure SetFrames(Value: Integer);
    procedure SetFrameWidth(Value: Integer);
    procedure SetFrame(Value: Integer);
    procedure SetActive(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetLoop(Value: Boolean);
    procedure SetReverse(Value: Boolean);
    procedure SetInterval(Value: Integer);
    procedure SetBorder(Value: Boolean);
    procedure DoTimer(Sender: TObject);
    procedure SetColors(Index: Integer; Value: TColor);
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMParentColorChanged(var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure SetAnimationLayout(const Value: TAnimationLayout);
  protected
    procedure Paint; override;
    property Animation: TBitmap read FAnimation write SetAnimation;
    property Frames: Integer read FFrames write SetFrames;
    property FrameWidth: Integer read FFrameWidth write SetFrameWidth;
    property Frame: Integer read FFrame write SetFrame default 1;
    property Interval: Integer read FInterval write SetInterval;
    property ColorTransparent: TColor index 0 read FTransColor write SetColors default clFuchsia;
    property ColorBorder: TColor index 1 read FBorderColor write SetColors default DefaultBorderColor;
    property Active: Boolean read FActive write SetActive;
    property Loop: Boolean read FLoop write SetLoop;
    property Reverse: Boolean read FReverse write SetReverse;
    property Border: Boolean read FBorder write SetBorder default false;
    property AnimationLayout: TAnimationLayout read FAnimationLayout write SetAnimationLayout;
    property OnFrameChange: TOnFrameChange read FFrameChange write FFrameChange;
    property Transparent: Boolean read FTransparent write SetTransparent default false;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { TFlatAnimation }
  TFlatAnimation = class(TDefineAnimation)
  published
    property Color;
    property Animation;
    property Frames;
    property FrameWidth;
    property Frame;
    property Interval;
    property ColorTransparent;
    property ColorBorder;
    property Active;
    property Loop;
    property Reverse;
    property Border;
    property AnimationLayout;
    property OnFrameChange;
    property Transparent;
    property Align;
    property Enabled;
    property ParentColor;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;
  { TDefineHint }
  TDefineHint = class(TVersionComponent)
  private
    FHintFont: TFont;
    FBackgroundColor: TColor;
    FBorderColor: TColor;
    FArrowBackgroundColor: TColor;
    FArrowColor: TColor;
    FHintWidth: Integer;
    FOnShowHint: TShowHintEvent;
    procedure SetColors (Index: Integer; Value: TColor);
    procedure SetHintFont (Value: TFont);
    procedure GetHintInfo (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  protected
    property ColorBackground: TColor index 0 read FBackgroundColor write SetColors default clWhite;
    property ColorBorder: TColor index 1 read FBorderColor write SetColors default clBlack;
    property ColorArrowBackground: TColor index 2 read FArrowBackgroundColor write SetColors default $0053D2FF;
    property ColorArrow: TColor index 3 read FArrowColor write SetColors default clBlack;
    property MaxWidth: Integer read FHintWidth write FHintWidth default 200;
    property Font: TFont read FHintFont write SetHintFont;
    property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
  end;
  { TDefineHintWindow }
  TDefineHintWindow = class(THintWindow)
  private
    FArrowPos: TArrowPos;
    FArrowPoint: TPoint;
    FHint: TDefineHint;
    function FindFlatHint: TDefineHint;
  protected
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    procedure ActivateHint(HintRect: TRect; const AHint: string); Override;
  end;
  TFlatHint = class(TDefineHint)
  published
    property ColorBackground;
    property ColorBorder;
    property ColorArrowBackground;
    property ColorArrow;
    property MaxWidth;
    property Font;
    property OnShowHint;
  end;
  { TBaseWater }
  TBaseWater = class(TVersionComponent)
  private
    FInterval: Cardinal;
    FHandle: HWND;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
  protected
    procedure Timer; dynamic;
    procedure UpdateTimer;
    procedure WndProc(var Msg: TMessage);
    property  Enabled: Boolean read FEnabled write SetEnabled default True;
    property  Interval: Cardinal read FInterval write SetInterval default 50;
    property  OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;
  TDefineImage = class(TVersionGraphic)
  private
    FBitmap: TBitmap;
    FOnProgress: TProgressEvent;
    FStretch: Boolean;
    FCenter: Boolean;
    FIncrementalDisplay: Boolean;
    FTransparent: Boolean;
    FDrawing: Boolean;
    FProportional: Boolean;
    FAutoShowCursor: Boolean;
    FAutoImage: Boolean;
    FLeaveImage: TBitmap;
    FEnterImage: TBitmap;
    FAutoCursor: TCursor;
    FMouseState: Boolean;
    procedure PictureChanged(Sender: TObject);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TBitmap);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparent(Value: Boolean);
    procedure SetProportional(Value: Boolean);
    procedure SetEnterImage(const Value: TBitmap);
    procedure SetLeaveImage(const Value: TBitmap);
  protected
    procedure MouseEnter(Var Msg:TMessage);message CM_MouseEnter;
    procedure MouseLeave(Var Msg:TMessage);message CM_MouseLeave;
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    function DestRect: TRect;
    function DoPaletteChange: Boolean;
    function GetPalette: HPALETTE; override;
    function GetCanvas: TCanvas;
    procedure Paint; override;
    procedure Progress(Sender: TObject; Stage: TProgressStage;
              PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
    property Center: Boolean read FCenter write SetCenter default False;
    property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
    property Proportional: Boolean read FProportional write SetProportional default false;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Transparent: Boolean read FTransparent write SetTransparent default False;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
    property BMPEnter:TBitmap read FEnterImage write SetEnterImage;
    property BMPLeave:TBitmap read FLeaveImage write SetLeaveImage;
    property AutoImage:Boolean read FAutoImage write FAutoImage default false;
    property AutoCursor:TCursor read FAutoCursor Write FAutoCursor default crHandPoint;
    property AutoShowCursor:Boolean read FAutoShowCursor write FAutoShowCursor default false;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Bitmap: TBitmap read FBitmap write SetPicture;
    property Canvas: TCanvas read GetCanvas;
    property OnMouseMove;
  end;   
  { TDefineWater }
  TDefineWater = class(TBaseWater)
  private
    FState: Integer;
    FParam: TOtherParam;
    FDamping: TWaterDamping;
    FBitmap: TBitmap;
    FImage: TDefineImage;
    FPlayState: boolean;
    FItems: TStringList;
    procedure SetDamping(Value: TWaterDamping);
    procedure SetItems(const Value: TStringList);
  protected
    FWater: TDefineWatet;
    FMoveHeight: Integer;
    procedure OnMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
    procedure Notification(AComponent: TComponent;Operation: TOperation); override;
    procedure Play(sender: TObject);
    procedure InitiateWater;
    property  Bitmap: TBitmap read FBitmap;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Damping: TWaterDamping read FDamping write SetDamping;
    property CtrlImage: TDefineImage read FImage write FImage;
    property Items: TStringList read FItems write SetItems;
    property Enabled;
    property Interval;
  end;
  { TFlatImage }
  TFlatImage = class(TDefineImage)
  published
    property AutoImage;
    property AutoCursor;
    property AutoShowCursor;
    property Align;
    property Anchors;
    property AutoSize;
    property Center;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property IncrementalDisplay;
    property ParentShowHint;
    property Bitmap;
    property BMPEnter;
    property BMPLeave;
    property PopupMenu;
    property Proportional;
    property ShowHint;
    property Stretch;
    property Transparent;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnProgress;
    property OnStartDock;
    property OnStartDrag;
  end;
  { TFlatWater }
  TFlatWater = class(TDefineWater)
  published
    property Damping;
    property CtrlImage;
    property Items;
    property Enabled;
    property Interval;
  end;

implementation

{$R FlatSysex.res}

uses FlatExcpt, FlatCnsts;  

{ Error reporting }

procedure RaiseGridError(const S: string);
begin
  raise EInvalidGridOperation.Create(S);
end;

{ TEduceData }

constructor TEduceData.Create(Collection: TCollection);
var
  Excel: TDefineExcel;
begin
  Excel := nil;
  if Assigned(Collection) and (Collection is TEduceDatas) then
     Excel := TEduceDatas(Collection).Cells;
  if Assigned(Excel) then Excel.BeginLayout;
  try
   inherited Create(Collection);
   FVisible  := True;
   FStored   := True;
  finally
   if Assigned(Excel) then Excel.EndLayout;
  end;
end;

destructor TEduceData.Destroy;
begin
  inherited Destroy;
end;

procedure TEduceData.Assign(Source: TPersistent);
begin
  if Source is TEduceData then
  begin
    if Assigned(Collection) then Collection.BeginUpdate;
    try
      FieldName := TEduceData(Source).FieldName;
      FCaption  := TEduceData(Source).Caption;
      FVisible  := TEduceData(Source).Visible;
      Changed(false);
    finally
      if Assigned(Collection) then Collection.EndUpdate;
    end;
  end else inherited Assign(Source);
end;

function TEduceData.GetExcel: TDefineExcel;
begin
  if Assigned(Collection) and (Collection is TEduceDatas) then
     Result := TEduceDatas(Collection).Cells
  else
     Result := nil;
end;

function TEduceData.GetDisplayName: string;
begin
  Result := FCaption;
  if Result = '' then
     Result := inherited GetDisplayName;
end;

procedure TEduceData.SetCaption(const Value: String);
begin
  if (Value <> FCaption) then
  begin
     FCaption := Value;
     Changed(false);
  end;
end;  

procedure TEduceData.SetField(Value: TField);
begin
  if FField = Value then Exit;
  if Assigned(FField) and (GetExcel <> nil) then
     FField.RemoveFreeNotification(GetExcel);
  if Assigned(Value) and (csDestroying in Value.ComponentState) then
     Value := nil;
  FField := Value;
  if Assigned(Value) then
  begin
    if GetExcel <> nil then
       FField.FreeNotification(GetExcel);
    FFieldName := Value.FullName;
    if (Length(FCaption)=0) and (Length(FieldName) > 0) then
    begin
       if Value.DisplayLabel = '' then
          FCaption := Value.FullName
       else
          FCaption := Value.DisplayLabel;
    end;
  end;
  if not IsStored then
  begin
    if Value = nil then
       FFieldName := '';
  end;
  Changed(False);
end;

function TEduceData.GetField: TField;
var
  Cell: TDefineExcel;
begin
  Cell := GetExcel;
  if (FField = nil) and (Length(FFieldName) > 0) and Assigned(Cell) and
      Assigned(Cell.DataLink.DataSet) then
  begin
  with Cell.Datalink.Dataset do
    if Active or (not DefaultFields) then
       SetField(FindField(FieldName));
  end;
  Result := FField;
end;

procedure TEduceData.SetFieldName(const Value: String);
var
  AField: TField;
  Cells: TDefineExcel;
begin
  AField := nil;
  Cells := GetExcel;
  if Assigned(Cells) and Assigned(Cells.DataLink.DataSet) and
    not (csLoading in Cells.ComponentState) and (Length(Value) > 0) then
      AField := Cells.DataLink.DataSet.FindField(Value); { no exceptions }
  FFieldName := Value;
  SetField(AField);
  Changed(False);
end;

procedure TEduceData.SetVisible(const Value: Boolean);
begin
  if Value <> FVisible then
  begin
     FVisible := Value;
     Changed(false);
  end;
end;

{ TEduceDatas }

constructor TEduceDatas.Create(DSExcel: TDefineExcel; ColumnClass: TEduceDataClass);
begin
  inherited Create(ColumnClass);
  FCells := DSExcel;
end;

function TEduceDatas.Add: TEduceData;
begin
  Result := TEduceData(inherited Add);
end;

function TEduceDatas.GetColumn(Index: Integer): TEduceData;
begin
  Result := TEduceData(inherited Items[Index]);
end;

function TEduceDatas.GetOwner: TPersistent;
begin
  Result := FCells;
end;

procedure TEduceDatas.LoadFromFile(const Filename: string);
var
  S: TFileStream;
begin
  S := TFileStream.Create(Filename, fmOpenRead);
  try
    LoadFromStream(S);
  finally
    S.Free;
  end;
end;

{ TEduceWrapper }
type
  TEduceWrapper = class(TComponent)
  private
    FColumns: TEduceDatas;
  published
    property Columns: TEduceDatas read FColumns write FColumns;
  end;

procedure TEduceDatas.LoadFromStream(S: TStream);
var
  Wrapper: TEduceWrapper;
begin
  Wrapper := TEduceWrapper.Create(nil);
  try
    Wrapper.Columns := FCells.CreateColumns;
    S.ReadComponent(Wrapper);
    Assign(Wrapper.Columns);
  finally
    Wrapper.Columns.Free;
    Wrapper.Free;
  end;
end;

procedure TEduceDatas.RebuildColumns;

  procedure AddFields(Fields: TFields; Depth: Integer);
  var
    I: Integer;
  begin
    Inc(Depth);
    for I := 0 to Fields.Count-1 do
    begin
      Add.FieldName := Fields[I].FullName;
      if Fields[I].DataType in [ftADT, ftArray] then
         AddFields((Fields[I] as TObjectField).Fields, Depth);
    end;
  end;

begin
  if Assigned(FCells) and Assigned(FCells.DataSource) and
     Assigned(FCells.Datasource.DataSet) then
  begin
    FCells.BeginLayout;
    try
      Clear;
      AddFields(FCells.DataSource.DataSet.Fields, 0);
    finally
      FCells.EndLayout;
    end
  end
  else
    Clear;
end;

procedure TEduceDatas.SaveToFile(const Filename: string);
var
  S: TStream;
begin
  S := TFileStream.Create(Filename, fmCreate);
  try
    SaveToStream(S);
  finally
    S.Free;
  end;
end;

procedure TEduceDatas.SaveToStream(S: TStream);
var
  Wrapper: TEduceWrapper;
begin
  Wrapper := TEduceWrapper.Create(nil);
  try
    Wrapper.Columns := Self;
    S.WriteComponent(Wrapper);
  finally
    Wrapper.Free;
  end;
end;

procedure TEduceDatas.SetColumn(Index: Integer; Value: TEduceData);
begin
  Items[Index].Assign(Value);
end;

procedure TEduceDatas.SetState(NewState: TEduceDatasState);
begin
  if NewState = State then Exit;
  if NewState = csDefault then
     Clear
  else
     RebuildColumns;
end;

function TEduceDatas.InternalAdd: TEduceData;
begin
  Result := Add;
  Result.FStored := False;
end;

function TEduceDatas.GetState: TEduceDatasState;
begin
  Result := TEduceDatasState((Count > 0) and Items[0].IsStored);
end;

procedure TEduceDatas.Update(Item: TCollectionItem);
begin
  if (FCells = nil) or (csLoading in FCells.ComponentState) then Exit;
  if Item = nil then
  begin
    FCells.LayoutChanged;
  end;
end;

{ TDefineExcel }

var
  ExcelBof    : array[0..5] of Word = ($809,  8, 0, $10,   0, 0);
  ExcelEof    : array[0..1] of Word = ($0A,  00);
  ExcelLabel  : array[0..5] of Word = ($204,  0, 0,   0,   0, 0);
  ExcelNum    : array[0..4] of Word = ($203, 14, 0,   0,   0);
  ExcelRec    : array[0..4] of Word = ($27E, 10, 0,   0,   0);
  ExcelBlank  : array[0..4] of Word = ($201,  6, 0,   0, $17);

Constructor TDefineExcel.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FColumns      := CreateColumns;
 FDatalink     := CreateDatalink;
 FEduceType    := dmDefault;
 FEduceTitle   := true;
 FInterval     := 500;
 FShowProgress := true;
 FFileName     := '未命名表格文件';
 FEduceMode    := emSingle;
 FDefaultExt   := '.xls';
end;

destructor TDefineExcel.Destroy;
begin
  FColumns.Free;
  FColumns := nil;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

function TDefineExcel.CreateColumns: TEduceDatas;
begin
  Result := TEduceDatas.Create(Self, TEduceData);
end;

procedure TDefineExcel.IncColRow;
begin
 if fCol = EduceCount - 1 then
 begin
    Inc(fRow);
    fCol :=0;
 end else
    Inc(fCol);
end;
//写空单元
procedure TDefineExcel.WriteBlankCell;
begin
 ExcelBlank[2] := fRow;
 ExcelBlank[3] := fCol;
 ExcelStream.WriteBuffer(ExcelBlank, SizeOf(ExcelBlank));
 IncColRow;
end;
//写浮点单元
procedure TDefineExcel.WriteFloatCell(const AValue: Double);
begin
 ExcelNum[2] := fRow;
 ExcelNum[3] := fCol;
 ExcelStream.WriteBuffer(ExcelNum, SizeOf(ExcelNum));
 ExcelStream.WriteBuffer(AValue, 8);
 IncColRow;
end;
//写整数单元
procedure TDefineExcel.WriteIntegerCell(const AValue: Integer);
var V: Integer;
begin
 ExcelRec[2] := fRow;
 ExcelRec[3] := fCol;
 ExcelStream.WriteBuffer(ExcelRec, SizeOf(ExcelRec));
 V := (AValue shl 2) or 2;
 ExcelStream.WriteBuffer(V, 4);
 IncColRow;
end;
//写字符单元
procedure TDefineExcel.WriteStringCell(const AValue: string);
var
 L: Word;
begin
 L := Length(AValue);
 ExcelLabel[1] := 8 + L;
 ExcelLabel[2] := fRow;
 ExcelLabel[3] := fCol;
 ExcelLabel[5] := L;
 ExcelStream.WriteBuffer(ExcelLabel, SizeOf(ExcelLabel));
 ExcelStream.WriteBuffer(Pointer(AValue)^, L);
 IncColRow;
end;
//写前缀
procedure TDefineExcel.WritePrefix;
begin
 ExcelStream.WriteBuffer(ExcelBof, SizeOf(ExcelBof));
end;
//写后缀
procedure TDefineExcel.WriteSuffix;
begin
 ExcelStream.WriteBuffer(ExcelEof, SizeOf(ExcelEof));
end;
//写标题
procedure TDefineExcel.WriteTitle;
var n: word;
begin
if FEduceTitle then
begin
 for n:= 0 to FColumns.Count - 1 do
 begin
   if FColumns[n].Visible then WriteStringCell(FColumns[n].Caption);
 end;
end;
end;

procedure TDefineExcel.StartProgress(Max:Integer);
begin
 if (not Assigned(FExcelForm))and(FShowProgress) then
    Application.CreateForm(TExcelForm, FExcelForm);
 if Assigned(FExcelForm) then
 begin
  with FExcelForm do
  begin
    ProGauge.Max     :=Max;
    ProGauge.Min     :=0;
    ProGauge.Progress:=0;
    Show;
    BringToFront;
  end;
 end;
end;

procedure TDefineExcel.EndProgress;
begin
 if Assigned(FExcelForm) then
 begin
  with FExcelForm do
  begin
    ProGauge.Progress := ProGauge.Progress+1;
    if ProGauge.Progress >= ProGauge.Max then
    begin
       Sleep(FInterval);
       Close;
    end;
  end;
  Application.ProcessMessages;
 end;
end;

procedure TDefineExcel.WriteData(Field:TField);
begin
   if Field.IsNull then
      WriteBlankCell
   else
   case FEduceType of
       dmDefault:
             case Field.DataType of
               ftSmallint,
               ftInteger,
               ftWord,
               ftAutoInc,
               ftBytes: WriteIntegerCell(Field.AsInteger);
               ftFloat,
               ftCurrency,
               ftBCD: WriteFloatCell(Field.AsFloat);
             else
               WriteStringCell(Field.AsString);
             end;
       dmString:WriteStringCell(Field.AsString);
   end;
end;
//正式写入Excel表的数据
procedure TDefineExcel.WriteDataCells;
var n: word;
    fBookMark : TBookmark;
begin
 //写入 Excel 文件开始格式
 WritePrefix;
 //写入标题名称
 WriteTitle;
 //开始写入各字段数据
 with FDataLink.DataSet do
 begin
  //禁止在数据感知控件中显示
  DisableControls;
  //初始化处理进度
  StartProgress(RecordCount);
  //记录当记录的位置
  fBookMark := GetBookmark;
  //指向第一条记录
  First;
  while not Eof do begin
   for n := 0 to ColumnCount - 1 do
   begin
    case FEduceMode of
     emSingle:
     begin
      if FColumns[n].Visible then
         WriteData(FColumns[n].Field);
     end;
     emDefault:
     begin
         WriteData(FColumns[n].Field);
     end;
    end;
   end;
   EndProgress;
   Next;
  end;
  //还原处理前的记录位置
  GotoBookmark(fBookMark);
  //充许在数据感知控件中显示
  EnableControls;
 end;
 //写入 Excel 文件结束标识
 WriteSuffix;
end;

procedure TDefineExcel.SaveExcel(Save: TStream);
begin
  fCol    := 0;
  fRow    := 0;
  ExcelStream := Save;
  WriteDataCells;
end;

procedure TDefineExcel.DefineFieldMap;
var
  I: Integer;
begin
  if FColumns.State = csCustomized then
  begin
    FDataLink.SparseMap := True;
    for I := 0 to FColumns.Count-1 do
      FDataLink.AddMapping(FColumns[I].FieldName);
  end
  else
  begin
    FDataLink.SparseMap := False;
    with FDataLink.Dataset do
      for I := 0 to FieldList.Count - 1 do
        with FieldList[I] do if Visible then FDataLink.AddMapping(FullName);
  end;
end;

procedure TDefineExcel.InitColumns;

  function FieldIsMapped(F: TField): Boolean;
  var
    X: Integer;
  begin
    Result := False;
    if F = nil then Exit;
    for X := 0 to FDataLink.FieldCount-1 do
      if FDataLink.Fields[X] = F then
      begin
        Result := True;
        Exit;
      end;
  end;

  procedure CheckForPassthroughs;  // check for Columns.State flip-flop
  var
    SeenPassthrough: Boolean;
    I, J: Integer;
    Column: TEduceData;
  begin
    SeenPassthrough := False;
    for I := 0 to FColumns.Count-1 do
      if not FColumns[I].IsStored then
        SeenPassthrough := True
      else if SeenPassthrough then
      begin
        for J := FColumns.Count-1 downto 0 do
        begin
          Column := FColumns[J];
          if not Column.IsStored then
            Column.Free;
        end;
        Exit;
      end;
  end;

  procedure ResetColumnFieldBindings;
  var
    I, J, K: Integer;
    Fld: TField;
    Column: TEduceData;
  begin
    if FColumns.State = csDefault then
    begin
      if (not FDataLink.Active) and (FDataLink.DefaultFields) then
          FColumns.Clear
      else
      begin
        for J := FColumns.Count-1 downto 0 do
        begin
          with FColumns[J] do
          begin
           if not Assigned(Field) or not FieldIsMapped(Field) then
              Free;
          end;
        end;
      end;
      I := FDataLink.FieldCount;
      //if (I = 0) and (FColumns.Count = 0) then
      //    Inc(I);
      for J := 0 to I-1 do
      begin
        Fld := FDataLink.Fields[J];
        if Assigned(Fld) then
        begin
          K := J;
          while (K < FColumns.Count) and (FColumns[K].Field <> Fld) do
            Inc(K);
          if K < FColumns.Count then
             Column := FColumns[K]
          else
          begin
             Column := FColumns.InternalAdd;
             Column.Field := Fld;
          end;
        end
        else
          Column := FColumns.InternalAdd;
        Column.Index := J;
      end;
    end
    else
    begin
      for I := 0 to FColumns.Count-1 do
          FColumns[I].Field := nil;
    end;
  end;
begin
  if ([csLoading, csDestroying] * ComponentState) <> [] then
     Exit;
  CheckForPassthroughs;
  FDatalink.ClearMapping;
  if FDatalink.Active then
     DefineFieldMap;
  ResetColumnFieldBindings;
end;

procedure TDefineExcel.SeTEduceType(const Value: TEduceType);
begin
 if FEduceType <> Value then
    FEduceType := Value;
end;

procedure TDefineExcel.SetColumns(const Value: TEduceDatas);
begin
  FColumns.Assign(Value);
end;

procedure TDefineExcel.DefineProperties(Filer: TFiler);
var
  StoreIt: Boolean;
  vState: TEduceDatasState;
begin
  vState := EduceDatas.State;
  if Filer.Ancestor = nil then
    StoreIt := vState = csCustomized
  else
    if vState <> TDefineExcel(Filer.Ancestor).EduceDatas.State then
      StoreIt := True
    else
      StoreIt := (vState = csCustomized) and
        (not CollectionsEqual(EduceDatas, TDefineExcel(Filer.Ancestor).EduceDatas, Self, TDefineExcel(Filer.Ancestor)));

  Filer.DefineProperty('Columns', ReadColumns, WriteColumns, StoreIt);
  inherited DefineProperties(Filer);
end;

procedure TDefineExcel.ReadColumns(Reader: TReader);
begin
  EduceDatas.Clear;
  Reader.ReadValue;
  Reader.ReadCollection(EduceDatas);
end;

procedure TDefineExcel.WriteColumns(Writer: TWriter);
begin
  if EduceDatas.State = csCustomized then
     Writer.WriteCollection(EduceDatas)
  else  // ancestor state is customized, ours is not
     Writer.WriteCollection(nil);
end;

function TDefineExcel.GetFieldCount: Integer;
begin
  if Assigned(FDataLink.DataSet) then
     result := FDataLink.FieldCount
  else
     result := 0;
end;

procedure TDefineExcel.BeginLayout;
begin
  BeginUpdate;
  if FLayoutLock = 0 then
     EduceDatas.BeginUpdate;
  Inc(FLayoutLock);
end;

procedure TDefineExcel.BeginUpdate;
begin
  Inc(FUpdateLock);
end;

procedure TDefineExcel.EndLayout;
begin
  if FLayoutLock > 0 then
  begin
    try
      try
        if FLayoutLock = 1 then
           InitColumns;
      finally
        if FLayoutLock = 1 then
           FColumns.EndUpdate;
      end;
    finally
      Dec(FLayoutLock);
      EndUpdate;
    end;
  end;
end;

procedure TDefineExcel.EndUpdate;
begin
  if FUpdateLock > 0 then
     Dec(FUpdateLock);
end;

procedure TDefineExcel.LayoutChanged;
begin
  if AcquireLayoutLock then
     EndLayout;
end;

function TDefineExcel.AcquireLayoutLock: Boolean;
begin
  Result := (FUpdateLock = 0) and (FLayoutLock = 0);
  if Result then BeginLayout;
end;

procedure TDefineExcel.Loaded;
begin
  inherited Loaded;
  LayoutChanged;
end;

function TDefineExcel.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDefineExcel.SetDataSource(const Value: TDataSource);
begin
  if Value = FDatalink.Datasource then Exit;
  if Assigned(Value) then
    if Assigned(Value.DataSet) then
      if Value.DataSet.IsUnidirectional then
         DatabaseError(SDataSetUnidirectional);
  FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TDefineExcel.LinkActive(Value: Boolean);
begin
  try
    LayoutChanged;
  finally
    //
  end;
end;

function TDefineExcel.CreateDataLink: TEduceLink;
begin
  Result := TEduceLink.Create(Self);
end;

function TDefineExcel.GetColumnCount: integer;
begin
  Result := FColumns.Count;
end;

function TDefineExcel.GetEduceCount: integer;
var
  i:integer;
begin
  result := 0;
  for i:= 0 to FColumns.Count - 1 do
      if FColumns[i].Visible then result := result + 1;
end;

procedure TDefineExcel.ExportAll;
var i:integer;
begin
  for i:=0 to ColumnCount - 1 do FColumns[i].Visible := True;
end;

function TDefineExcel.GetFields(FieldIndex: Integer): TField;
begin
  Result := FDatalink.Fields[FieldIndex];
end;

procedure TDefineExcel.CancelLayout;
begin
  if FLayoutLock > 0 then
  begin
    if FLayoutLock = 1 then
       EduceDatas.EndUpdate;
    Dec(FLayoutLock);
    EndUpdate;
  end;
end;

procedure TDefineExcel.ExecuteSave;
var
  SaveDlg: TSaveDialog;
  FileStream: TFileStream;
  inx: integer;
  UseState: boolean;
  tFile:String;
begin
case FEduceMode of
 emSingle:
 begin
 FieldForm := TFieldForm.Create(self);
 try
  FieldForm.FieldBox.Items.Clear;
  for inx := 0 to FColumns.Count - 1 do
  begin
      FieldForm.FieldBox.Items.Add(FColumns[inx].Caption);
      FieldForm.FieldBox.Checked[inx] := FColumns[inx].Visible;
  end;
  FieldForm.ShowModal;
  if FieldForm.ModalResult = mrOk then
  begin
   for inx := 0 to FieldForm.FieldBox.Items.Count - 1 do
       FColumns[inx].Visible := FieldForm.FieldBox.Checked[inx];
   SaveDlg := TSaveDialog.Create(self);
   try
    SaveDlg.DefaultExt := FDefaultExt;
    SaveDlg.Filter     := '微软电子表格(MS-EXCEL文件)|*.XLS';
    SaveDlg.Title      := '保存为';
    SaveDlg.FileName   := FFileName;
    if SaveDlg.Execute then
    begin
     if Assigned(FDataLink.DataSet) then
     begin
      useState := true;
      if FileExists(SaveDlg.FileName) then
         useState := DeleteFile(SaveDlg.FileName);
      if useState then
      begin
       FileStream := TFileStream.Create(SaveDlg.FileName, fmCreate);
       try
        SaveExcel(FileStream);
       Finally
        FileStream.Free;
       end;
      end
      else ShowMessage('文件正在使用中,不能覆盖文件!');
     end;
    end;
   finally
    SaveDlg.Free;
   end;
  end;
 finally
  FieldForm.Free;
  FieldForm := Nil;
 end;
 end;
 emDefault:
 begin
   if Assigned(FDataLink.DataSet) then
     begin
      useState := true;
      tFile    := FFileName;
      if UpperCase(ExtractFileExt(FFileName))<>UpperCase(FDefaultExt) then
         tFile := FFileName + FDefaultExt;
      if FileExists(tFile) then
         useState := DeleteFile(tFile);
      if useState then
      begin
       FileStream := TFileStream.Create(tFile, fmCreate);
       try
        SaveExcel(FileStream);
       Finally
        FileStream.Free;
       end;
      end
      else ShowMessage('文件正在使用中,不能覆盖文件!');
     end;
 end;
end;
end;

procedure TDefineExcel.InitFields;
var
  inx: integer;
  Col: TEduceData;
begin
 if Assigned(FDataLink.DataSet) then
 begin
 with FDataLink.DataSet.FieldDefs do
 begin
  if (not FDataLink.Active) and (Count > 0) then
  begin
    FColumns.BeginUpdate;
    FColumns.Clear;
    for inx:=0 to Count - 1 do
    begin
      Col := FColumns.Add;
      Col.FieldName := Items[inx].Name;
      Col.Caption   := Items[inx].Name;
    end;
    FColumns.EndUpdate;
  end;
 end;
 end;
end;

procedure TDefineExcel.ClearFields;
begin
 FColumns.BeginUpdate;
 FColumns.Clear;
 FColumns.EndUpdate;
end;

procedure TDefineExcel.RestoreFields;
var
 inx : integer;
 col : TEduceData;
begin
 FColumns.BeginUpdate;
 for inx:=0 to FColumns.Count - 1 do
 begin
   Col := FColumns[inx];
   Col.Caption  := Col.FieldName;
   Col.Visible  := True;
 end;
 FColumns.EndUpdate;
end;

procedure TDefineExcel.SetDefaultExt(Value: String);
begin
  if FDefaultExt <> Value then
  begin
     if Value[1] <> '.' then
        Value := '.'+value;
     FDefaultExt := Value;
  end;
end;

{ TEduceLink }

const
  MaxMapSize = (MaxInt div 2) div SizeOf(Integer);

type
  TIntArray = array[0..MaxMapSize] of Integer;
  PIntArray = ^TIntArray;

constructor TEduceLink.Create(ADSExcel: TDefineExcel);
begin
  inherited Create;
  FCells        := ADSExcel;
  VisualControl := True;
end;

destructor TEduceLink.Destroy;
begin
  ClearMapping;
  inherited Destroy;
end;

function TEduceLink.GetDefaultFields: Boolean;
var
  I: Integer;
begin
  Result := True;
  if DataSet <> nil then
     Result := DataSet.DefaultFields;
  if Result and SparseMap then
  for I := 0 to FFieldCount-1 do
    if FFieldMap[I] < 0 then
    begin
      Result := False;
      Exit;
    end;
end;

function TEduceLink.GetFields(I: Integer): TField;
begin
  if (0 <= I) and (I < FFieldCount) and (FFieldMap[I] >= 0) then
    Result := DataSet.FieldList[FFieldMap[I]]
  else
    Result := nil;
end;

function TEduceLink.AddMapping(const FieldName: string): Boolean;
var
  Field: TField;
  NewSize: Integer;
begin
  Result := True;
  if FFieldCount >= MaxMapSize then
     RaiseGridError(STooManyColumns);
  if SparseMap then
     Field := DataSet.FindField(FieldName)
  else
     Field := DataSet.FieldByName(FieldName);

  if FFieldCount = Length(FFieldMap) then
  begin
    NewSize := Length(FFieldMap);
    if NewSize = 0 then
       NewSize := 8
    else
       Inc(NewSize, NewSize);
    if (NewSize < FFieldCount) then
        NewSize := FFieldCount + 1;
    if (NewSize > MaxMapSize) then
        NewSize := MaxMapSize;
    SetLength(FFieldMap, NewSize);
  end;
  if Assigned(Field) then
  begin
    FFieldMap[FFieldCount] := Dataset.FieldList.IndexOfObject(Field);
    Field.FreeNotification(FCells);
  end
  else
    FFieldMap[FFieldCount] := -1;
  Inc(FFieldCount);
end;

procedure TEduceLink.ActiveChanged;
begin
  if Active and Assigned(DataSource) then
    if Assigned(DataSource.DataSet) then
      if DataSource.DataSet.IsUnidirectional then
         DatabaseError(SDataSetUnidirectional);
  FCells.LinkActive(Active);
  FModified := False;
end;

procedure TEduceLink.ClearMapping;
begin
  FFieldMap   := nil;
  FFieldCount := 0;
end;

procedure TEduceLink.LayoutChanged;
var
  SaveState: Boolean;
begin
  SaveState := FCells.LayoutSet;
  FCells.LayoutSet := True;
  try
    FCells.LayoutChanged;
  finally
    FCells.LayoutSet := SaveState;
  end;
  inherited LayoutChanged;
end;

function TEduceLink.GetMappedIndex(ColIndex: Integer): Integer;
begin
  if (0 <= ColIndex) and (ColIndex < FFieldCount) then
    Result := FFieldMap[ColIndex]
  else
    Result := -1;
end;

function TEduceLink.IsAggRow(Value: Integer): Boolean;
begin
  Result := False;
end;
{ TFlatSound }
const
  Flags = SND_RESOURCE or SND_SYNC;

constructor TFlatSound.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Event := seBtnClick;
end;

procedure TFlatSound.Play;
begin
  case FEvent of
    seBtnClick:    PlaySound('ENC_001',0,Flags);
    seMenu:        PlaySound('ENC_002',0,Flags);
    seMenuClick:   PlaySound('ENC_003',0,Flags);
    seMoveIntoBtn: PlaySound('ENC_004',0,Flags);
    sePanelExpand: PlaySound('ENC_005',0,Flags);
  end;
end;

procedure TFlatSound.PlayThis(ThisEvent: TSoundEvent);
begin
  case ThisEvent of
    seBtnClick:    PlaySound('ENC_001',0,Flags);
    seMenu:        PlaySound('ENC_002',0,Flags);
    seMenuClick:   PlaySound('ENC_003',0,Flags);
    seMoveIntoBtn: PlaySound('ENC_004',0,Flags);
    sePanelExpand: PlaySound('ENC_005',0,Flags);
  end;
end;
{ TFlatAnimWnd }
var
  OwnerList: TList;

constructor TFlatAnimHookWnd.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAnimateWindow := TFlatAnimWnd(AOwner);
end;

procedure TFlatAnimHookWnd.WMCreate(var Message: TMessage);
begin
  inherited;
  FAnimateWindow.OwnerWndCreated;
end;

procedure TFlatAnimHookWnd.WMDestroy(var Message: TMessage);
begin
  FAnimateWindow.OwnerWndDestroyed;
  inherited;
end;

constructor TFlatAnimWnd.Create(AOwner: TComponent);
begin
  FOwner := AOwner;
  if OwnerList.IndexOf(FOwner) <> -1 then
  begin
    FOwner := nil;
    raise Exception.Create('Owner must be TFORM');
  end;
  inherited Create(AOwner);
  if not (csDesigning in ComponentState) then
  begin
    FHookWnd := TFlatAnimHookWnd.Create(Self);
    if Application.MainForm = nil then
    begin
      FNewAppProc := MakeObjectInstance(NewAppWndProc);
      FOldAppProc := Pointer(GetWindowLong(Application.Handle, GWL_WNDPROC));
      SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(FNewAppProc));
    end;
  end;
  OwnerList.Add(FOwner);
end;

destructor TFlatAnimWnd.Destroy;
begin
  if not(csDesigning in ComponentState) then
  begin
    if Application.MainForm = nil then
    begin
      SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(FOldAppProc));
      FreeObjectInstance(FNewAppProc);
    end;
  end;
  if OwnerList.IndexOf(FOwner) <> -1 then
    OwnerList.Remove(FOwner);
  inherited Destroy;
end;

procedure TFlatAnimWnd.SetParentComponent(Value: TComponent);
begin
  inherited SetParentComponent(Value);
  if not(csDesigning in ComponentState) then
    if Value is TWinControl then
      FHookWnd.Parent := TWinControl(Value);
end;

procedure TFlatAnimWnd.OwnerWndCreated;
begin
  FNewProc := MakeObjectInstance(NewWndProc);
  FOldProc := Pointer(GetWindowLong((FOwner as TForm).Handle, GWL_WNDPROC));
  SetWindowLong((FOwner as TForm).Handle, GWL_WNDPROC, Longint(FNewProc));
end;

procedure TFlatAnimWnd.OwnerWndDestroyed;
begin
  SetWindowLong((FOwner as TForm).Handle, GWL_WNDPROC, Longint(FOldProc));
  FreeObjectInstance(FNewProc);
end;

procedure TFlatAnimWnd.NewAppWndProc(var Message: TMessage);
begin
  with Message do
  begin
    if Msg = WM_SYSCOMMAND then
      case WParam of
        SC_MINIMIZE:
          MinimizeWnd;
        SC_RESTORE:
          RestoreWnd;
      end;
    Result := CallWindowProc(FOldAppProc, Application.Handle, Msg, wParam, lParam);
  end;
end;

procedure TFlatAnimWnd.NewWndProc(var Message: TMessage);
begin
  with Message do
  begin
    if (Msg = WM_SYSCOMMAND) and (WParam = SC_MINIMIZE) then
    begin
      if Application.MainForm = FOwner then
        MinimizeWnd
      else
        PostMessage(Application.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
    end
    else
    begin
      if (Msg = WM_WINDOWPOSCHANGING) and (PWindowPos(lParam)^.flags = (SWP_NOSIZE or SWP_NOMOVE)) then
      begin
        if IsIconic(Application.Handle) then
          PostMessage(Application.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
      end
    end;
    Result := CallWindowProc(FOldProc, (FOwner as TForm).Handle, Msg, wParam, lParam);
  end;
end;

procedure TFlatAnimWnd.MinimizeWnd;
var
  Rect: TRect;
begin
  with Application do
  begin
    if not(IsWindowEnabled(Handle)) then
      EnableWindow(Handle, True);
    GetWindowRect((FOwner as TForm).Handle, Rect);
    SetForegroundWindow(Handle);
    SetWindowPos(Handle, 0, Rect.Left, Rect.Top, Rect.Right - Rect.Left, 0, SWP_NOZORDER);
    DefWindowProc(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
    ShowWindow(Handle, SW_MINIMIZE);
  end;
  if Assigned(FOnMinimize) then
    FOnMinimize(Application);
end;

procedure TFlatAnimWnd.RestoreWnd;
var
  MainFormPlacement: TWindowPlacement;
  AppWndPlacement: TWindowPlacement;
begin
  with Application do
  begin
    MainFormPlacement.length := SizeOf(TWindowPlacement);
    MainFormPlacement.flags  := 0;
    GetWindowPlacement(MainForm.Handle, @MainFormPlacement);
    AppWndPlacement.length := SizeOf(TWindowPlacement);
    AppWndPlacement.flags  := 0;
    GetWindowPlacement(Handle, @AppWndPlacement);
    AppWndPlacement.rcNormalPosition := MainFormPlacement.rcNormalPosition;
    AppWndPlacement.rcNormalPosition.Bottom := AppWndPlacement.rcNormalPosition.Top;
    SetWindowPlacement(Handle, @AppWndPlacement);
    SetForegroundWindow(Handle);
    DefWindowProc(Application.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
    ShowWindow(Handle, SW_RESTORE);
    SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER);
    if not(MainForm.Visible) then
    begin
      ShowWindow(MainForm.Handle, SW_RESTORE);
      MainForm.Visible := True;
    end;
  end;
  if Assigned(FOnRestore) then
    FOnRestore(Application);
end;

procedure TFlatAnimWnd.Minimize;
begin
  SendMessage((FOwner as TForm).Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
end;

{ TDefineSingle }

constructor TDefineSingle.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FActive  := True;
  FTitle   := 'This program already run!';
  FCaption := '&Exit';
end;

procedure TDefineSingle.Loaded;
begin
  inherited Loaded;
  Run(Active,Title);
end;

procedure TDefineSingle.Run(State: Boolean;Title:String);
begin
  if (State)and(not(csDesigning in ComponentState)) then
  begin
   //with Application do
   //begin
    try
      if OpenMutex(MUTEX_ALL_ACCESS, False, pchar(Application.Title)) = 0 then
      begin
        inherited;
        ReleaseMutex(CreateMutex(nil, False, pchar(Application.Title)));
      end else begin
        Application.ShowMainForm := False;
        ShowDialog(Title, Caption);
        Application.Terminate;
      end;
    finally
    end;
   //end;
  end;
end;

procedure TDefineSingle.SetActive(Value: boolean);
begin
  if FActive <> Value then begin
     FActive := Value;
     Run(FActive,FTitle);
  end;
end;

procedure TDefineSingle.SetTitle(const Value: string);
begin
  if FTitle <> Value then FTitle := Value;
end;

procedure TDefineSingle.SetCaption(const Value: string);
begin
  if FCaption <> Value then FCaption := Value;
end;

{ TDefineTimer }
procedure TimerCallback(uTimerID, uMessage: Cardinal; dwUser, dw1, dw2: Cardinal); stdcall;
var
  FlatTimer: TDefineTimer;
begin
  FlatTimer := TDefineTimer(dwUser);
  if Assigned(FlatTimer) then FlatTimer.Timer;
end;

constructor TDefineTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled  := True;
  FInterval := 1000;
  FPeriod   := 10;
  uTimerID  := 0;
end;

destructor TDefineTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  inherited Destroy;
end;

procedure TDefineTimer.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then begin
     FEnabled := Value;
     UpdateTimer;
  end;
end;

procedure TDefineTimer.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then begin
     FInterval := Value;
     UpdateTimer;
  end;
end;

procedure TDefineTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TDefineTimer.SetPeriod(Value: Cardinal);
var Caps: TTimeCaps;
begin
  if (Value <> FPeriod) and (timeGetDevCaps(@Caps, Sizeof(TTimeCaps)) <> 0) then
  begin
    if Value < Caps.wPeriodMin then //小于最小分辨率
       Value := 0
    else if Value > Caps.wPeriodMax then //大于最小分辨率
       Value := Caps.wPeriodMax;
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TDefineTimer.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(self);
end;

procedure TDefineTimer.UpdateTimer;
var lpProc: TFNTimeCallBack;
begin
  if uTimerID <> 0 then timeKillEvent(uTimerID); //销毁
  if (FInterval > 0) and FEnabled and Assigned(FOnTimer) then
  begin
    lpProc   := TimerCallback;
    uTimerID := TimeSetEvent(FInterval,FPeriod,lpProc,DWORD(Self),TIME_PERIODIC);
    if uTimerID = 0 then begin
       FEnabled := FALSE;
       raise Exception.Create('Failed to create Timer!');
    end;
  end;
end;

{ TDefineTaskbarIcon }

const WM_TASKICON = WM_USER;

constructor TDefineTaskbarIcon.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle := AllocateHWnd(PrivateWndProc);
  FWMTaskBarCreated := RegisterWindowMessage('TaskbarCreated');
  Application.HookMainWindow(AppHook);
  FIcon     := TIcon.Create;
  FHintMode := thDefault;
  FIconMode := thDefault;
end;

destructor TDefineTaskbarIcon.Destroy;
begin
  if FActive then SetActive(False);
  Application.UnhookMainWindow(AppHook);
  FIcon.Free;
  if FHandle <> 0 then DeallocateHwnd(FHandle);
  inherited Destroy;
end;

procedure TDefineTaskbarIcon.PrivateWndProc(var Message: TMessage);
begin
  WndProc(Message);
end;

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

procedure TDefineTaskbarIcon.SetActive(Value: Boolean);
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if Value then
       AddIcon
    else
       DeleteIcon;
  end;
end;

procedure TDefineTaskbarIcon.SetHint(Value: string);
begin
  FHint := Value;
  ModifyIcon(NIF_TIP);
end;

procedure TDefineTaskbarIcon.SetIcon(Value: TIcon);
begin
  FIcon.Assign(Value);
  ModifyIcon(NIF_ICON);
end;

function TDefineTaskbarIcon.DoIcon(Action: DWORD; Aspect: UINT): Boolean;
var
  Data: TNotifyIconData;
begin
  with Data do
  begin
    cbSize := SizeOf(Data);
    wnd    := FHandle;
    uID    := 0;
    uFlags := Aspect or NIF_MESSAGE;
    uCallbackMessage := WM_TASKICON;
    if Aspect and NIF_ICON <> 0 then
     case FIconMode of
      thCustom:
      if FIcon.Handle <> 0 then
         hIcon := FIcon.Handle
      else
         hIcon := LoadIcon(0, IDI_WINLOGO);
      thDefault:
         hIcon := Application.Icon.Handle;
     end;
    if Aspect and NIF_TIP <> 0 then
       Case FHintMode of
        thDefault: StrPLCopy(szTip, PChar(Application.Title), SizeOf(szTip));
        thCustom : StrLCopy(szTip, PChar(FHint), SizeOf(szTip));
       end;
  end;
  if not (csDesigning in ComponentState) then begin
     Result := Shell_NotifyIcon(Action, @Data);
  end else
     Result := False;
end;

function TDefineTaskbarIcon.AddIcon: Boolean;
begin
  Result := DoIcon(NIM_ADD, NIF_TIP or NIF_ICON);
end;

function TDefineTaskbarIcon.ModifyIcon(Aspect: Integer): Boolean;
begin
  if FActive then
     Result := DoIcon(NIM_MODIFY, Aspect)
  else
     Result := False;
end;

function TDefineTaskbarIcon.DeleteIcon: Boolean;
begin
  Result := DoIcon(NIM_DELETE, 0);
end;

procedure TDefineTaskbarIcon.WndProc(var Message: TMessage);
var Pt: TPoint;
begin
  with Message do
  begin
    if Msg = WM_TASKICON then
    case LParam of
      WM_LBUTTONUP:
        if Assigned(FOnClick) then FOnClick(Self);
      WM_LBUTTONDBLCLK:
        if Assigned(FOnDblClick) then FOnDblClick(Self);
      WM_RBUTTONUP:
        if Assigned(FOnRightClick) then
           FOnRightClick(Self)
        else if Assigned(FPopupMenu) then begin 
           SetForegroundWindow(FHandle);
           GetCursorPos(Pt);
           FPopupMenu.Popup(Pt.X, Pt.Y);
           PostMessage(FHandle, WM_USER, 0, 0);
        end;
      WM_MOUSEMOVE:
        if Assigned(FOnMouseMove) then FOnMouseMove(Self);
    end
    else
      Result := DefWindowProc(Handle, Msg, WParam, LParam);
  end;
end;

function TDefineTaskbarIcon.AppHook(var Message: TMessage): Boolean;
begin
  Result := Message.Msg = FWMTaskbarCreated;
  if Result then AddIcon;
end;


procedure TDefineTaskbarIcon.SetPopupMenu(const Value: TPopupMenu);
begin
  FPopupMenu := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TDefineTaskbarIcon.SetHintMode(const Value: TDefineTaskbarMode);
begin
  if FHintMode <> Value then
  begin
     FHintMode := Value;
     ModifyIcon(NIF_TIP);
  end;
end;

procedure TDefineTaskbarIcon.SetIconMode(const Value: TDefineTaskbarMode);
begin
  if FIconMode <> Value then
  begin
     FIconMode := Value;
     ModifyIcon(NIF_ICON);
  end;
end;

procedure TDefineTaskbarIcon.Loaded;
begin
  inherited Loaded;
  if FActive then AddIcon;
end;

{ TDefineAnimation }
constructor TDefineAnimation.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAnimation   := TBitmap.Create;
  ControlStyle := ControlStyle + [csOpaque];
  SetBounds(0, 0, 60, 60);
  FTransColor  := clFuchsia;
  FBorderColor := DefaultBorderColor;
  FBorder      := false;
  FTransparent := false;
  FActive      := False;
  FLoop        := True;
  FInterval    := 100; // 1 Second
  FFrameWidth  := 30;
  FFrames      := 1;
  FFrame       := 0;
end;

destructor TDefineAnimation.Destroy;
begin
  FAnimation.Free;       
  inherited Destroy;
end;

procedure TDefineAnimation.Paint;
var
  X, Y, Pos, W, H: Integer;
  SrcRect, DestRect: TRect;
  memGlyph: TBitmap;
begin
 W := FAnimation.Width div FFrames;
 H := FAnimation.Height div FFrames;
 case FAnimationLayout of
    alAcross:
      begin
        X   := (Width - W) div 2;
        Y   := (Height - FAnimation.Height) div 2;
        Pos := W * FFrame;
        DestRect := Rect(X, Y, X + W, Y + FAnimation.Height);
        SrcRect  := Rect(Pos, 0, Pos + W, FAnimation.Height);
      end;
    alDown:
      begin
        X   := (Width - FFrameWidth) div 2;
        Y   := (Height - H) div 2;
        Pos := H * FFrame;
        DestRect := Rect(X, Y, X + FFrameWidth, Y + H);
        SrcRect  := Rect(0, Pos, FFrameWidth, Pos + FFrameWidth);
      end;
 end;
 memGlyph := TBitmap.Create;
 try
  memGlyph.Height := Height;
  memGlyph.Width  := Width;
  with memGlyph.Canvas do
  begin
   Brush.Style := bsClear;
   Brush.Color := Color;
   FillRect(ClipRect);
   if FTransparent then begin
      DrawParentImage(self, memGlyph.Canvas);
      Brush.Style := bsClear;
      Brush.Color := FTransColor; 
      BrushCopy(DestRect, FAnimation, SrcRect, FTransColor);
   end else begin
      CopyRect(DestRect, FAnimation.Canvas, SrcRect);
   end;
   if (csDesigning in ComponentState) and (not FBorder) then
   begin
      Pen.Style   := psDot;
      Pen.Color   := clBlack;
      Brush.Style := bsClear;
      Rectangle(ClipRect);
   end else if FBorder then begin
      DrawButtonBorder(memGlyph.Canvas, ClipRect, FBorderColor, 1);
   end;
  end;
  Canvas.CopyRect(ClientRect, memGlyph.Canvas, ClientRect);
 finally
  memGlyph.Free;
 end;
end;

procedure TDefineAnimation.SetAnimation(Value: TBitmap);
begin
  if Value <> FAnimation then
  begin
    FAnimation.Assign(Value);
    if not FAnimation.Empty then
    begin
      if FAnimation.Width > FAnimation.Height then
         FAnimationLayout := alAcross
      else
         FAnimationLayout := alDown;
      case FAnimationLayout of
        alAcross:
          if FAnimation.Width mod FAnimation.Height = 0 then
            FFrames := FAnimation.Width div FAnimation.Height;
        alDown:
          if FAnimation.Height mod FAnimation.Width = 0 then
            FFrames := FAnimation.Height div FAnimation.Width;
      end;
      FFrame := 1;
      case FAnimationLayout of
        alAcross:
          FFrameWidth := FAnimation.Width div FFrames;
        alDown:
          FFrameWidth := FAnimation.Height div FFrames;
      end;
      FTransColor := FAnimation.Canvas.Pixels[0, FAnimation.Height - 1];
    end;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetFrames(Value: Integer);
begin
  if Value <> FFrames then
  begin
    FFrames := Value;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetFrameWidth(Value: Integer);
begin
  if Value <> FFrameWidth then
  begin
    FFrameWidth := Value;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetFrame(Value: Integer);
var
  Temp: Integer;
begin
  if Value < 0 then
     Temp := FFrames - 1
  else
     Temp := Value mod FFrames;
  if Temp <> FFrame then
  begin
    FFrame := Temp;
    if Assigned(FFrameChange) then
    begin
      FFrameChange(Self,FFrame);
    end;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetActive(Value: Boolean);
begin
  if Value <> FActive then
  begin
    FActive := Value;
    if not Value then
    begin
      FTimer.Free;
      FTimer := nil;
    end
    else
      if FInterval > 0 then
      begin
        FTimer := TTimer.Create(Self);
        FTimer.Interval := FInterval;
        FTimer.OnTimer := DoTimer;
      end;
  end;
end;

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

procedure TDefineAnimation.SetLoop(Value: Boolean);
begin
  if Value <> FLoop then
  begin
    FLoop := Value;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetReverse(Value: Boolean);
begin
  if Value <> FReverse then
  begin
     FReverse := Value;
     Invalidate;
  end;
end;

procedure TDefineAnimation.SetInterval(Value: Integer);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    if FActive then
       FTimer.Interval := Value;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetBorder(Value: Boolean);
begin
  if Value <> FBorder then
  begin
    FBorder := Value;
    Invalidate;
  end;
end;

procedure TDefineAnimation.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    0: FTransColor := Value;
    1: FBorderColor := Value;
  end;
  Invalidate;
end;

procedure TDefineAnimation.CMSysColorChange (var Message: TMessage);
begin
  inherited;
  if (ParentColor)and(Parent<>nil) then
  begin
    ParentColor := True;
    Color := TForm(Parent).Color;
  end;
  Invalidate;
end;

procedure TDefineAnimation.CMParentColorChanged (var Message: TWMNoParams);
begin
  inherited;
  if (ParentColor)and(Parent<>nil) then
  begin
    ParentColor := True;
    Color := TForm(Parent).Color;
  end;
  Invalidate;
end;

procedure TDefineAnimation.WMSize (var Message: TWMSize);
begin
  inherited;
  Invalidate;
end;

procedure TDefineAnimation.DoTimer(Sender: TObject);
  procedure ChkStop;
  begin
    if not FLoop then
    begin
      FActive := False;
      FTimer.Free;
      FTimer := nil;
    end;
  end;
begin
  if FReverse then
  begin
    Frame := Frame - 1;
    if FFrame = 0 then ChkStop;
  end
  else
  begin
    Frame := Frame + 1;
    if FFrame = Frames - 1 then ChkStop;
  end;
end;

procedure TDefineAnimation.SetAnimationLayout(const Value: TAnimationLayout);
begin
  FAnimationLayout := Value;
  Invalidate;
end;

{ TDefineHint }
constructor TDefineHint.Create (AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHintFont := TFont.Create;
  if not (csDesigning in ComponentState) then
  begin
    HintWindowClass := TDefineHintWindow;
    with Application do
    begin
      ShowHint   := not ShowHint;
      ShowHint   := not ShowHint;
      OnShowHint := GetHintInfo;
      HintShortPause := 25;
      HintPause      := 500;
      HintHidePause  := 5000;
    end;
  end;
  FBackgroundColor      := clWhite;
  FBorderColor          := clBlack;
  FArrowBackgroundColor := $0053D2FF;
  FArrowColor           := clBlack;
  FHintWidth            := 200;
end;

destructor TDefineHint.Destroy;
begin
  FHintFont.Free;
  inherited Destroy;
end;

procedure TDefineHint.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    0: FBackgroundColor      := Value;
    1: FBorderColor          := Value;
    2: FArrowBackgroundColor := Value;
    3: FArrowColor           := Value;
  end;
end;

procedure TDefineHint.SetHintFont (Value: TFont);
begin
  FHintFont.Assign(Value);
end;

procedure TDefineHint.GetHintInfo (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
  if Assigned(FOnShowHint) then
     FOnShowHint(HintStr, CanShow, HintInfo);
end;

{ TDefineHintWindow }

function TDefineHintWindow.FindFlatHint: TDefineHint;
var
  curInx: Integer;
begin
  Result := nil;

  with Application.MainForm do
    for curInx := 0 to ComponentCount - 1 do
      if Components[curInx] is TDefineHint then
      begin
        Result := TDefineHint(Components[curInx]);
        Break;
      end;
end;

procedure TDefineHintWindow.CreateParams (var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style - WS_BORDER;
end;

procedure TDefineHintWindow.Paint;
var
  ArrowRect, TextRect: TRect;
begin
  // Set the Rect's
  case FArrowPos of
    NW, SW:
      begin
        ArrowRect := Rect(ClientRect.Left + 1, ClientRect.Top + 1, ClientRect.Left + 15, ClientRect.Bottom - 1);
        TextRect  := Rect(ClientRect.Left + 15, ClientRect.Top + 1, ClientRect.Right - 1, ClientRect.Bottom - 1);
      end;
    NE, SE:
      begin
        ArrowRect := Rect(ClientRect.Right - 15, ClientRect.Top + 1, ClientRect.Right - 1, ClientRect.Bottom - 1);
        TextRect  := Rect(ClientRect.Left + 1, ClientRect.Top + 1, ClientRect.Right - 15, ClientRect.Bottom - 1);
      end;
  end;

  // DrawBackground
  canvas.brush.color := FHint.FArrowBackgroundColor;
  canvas.FillRect(ArrowRect);
  canvas.brush.color := FHint.FBackgroundColor;
  canvas.FillRect(TextRect);

  // DrawBorder
  canvas.Brush.Color := FHint.FBorderColor;
  canvas.FrameRect(ClientRect);

  // DrawArrow
  case FArrowPos of
    NW: FArrowPoint := Point(ArrowRect.Left + 2, ArrowRect.Top + 2);
    NE: FArrowPoint := Point(ArrowRect.Right - 3, ArrowRect.Top + 2);
    SW: FArrowPoint := Point(ArrowRect.Left + 2, ArrowRect.Bottom - 3);
    SE: FArrowPoint := Point(ArrowRect.Right - 3, ArrowRect.Bottom - 3);
  end;
  canvas.Pen.Color := FHint.FArrowColor;
  case FArrowPos of
    NW: canvas.Polyline([Point(FArrowPoint.x,     FArrowPoint.y),     Point(FArrowPoint.x, FArrowPoint.y + 6),
                         Point(FArrowPoint.x + 1, FArrowPoint.y + 6), Point(FArrowPoint.x + 1, FArrowPoint.y),
                         Point(FArrowPoint.x + 6, FArrowPoint.y),     Point(FArrowPoint.x + 6, FArrowPoint.y + 1),
                         Point(FArrowPoint.x + 2, FArrowPoint.y + 1), Point(FArrowPoint.x + 2, FArrowPoint.y + 4),
                         Point(FArrowPoint.x + 5, FArrowPoint.y + 7), Point(FArrowPoint.x + 6, FArrowPoint.y + 7),
                         Point(FArrowPoint.x + 3, FArrowPoint.y + 4), Point(FArrowPoint.x + 3, FArrowPoint.y + 3),
                         Point(FArrowPoint.x + 6, FArrowPoint.y + 6), Point(FArrowPoint.x + 7, FArrowPoint.y + 6),
                         Point(FArrowPoint.x + 3, FArrowPoint.y + 2), Point(FArrowPoint.x + 4, FArrowPoint.y + 2),
                         Point(FArrowPoint.x + 7, FArrowPoint.y + 5), Point(FArrowPoint.x + 7, FArrowPoint.y + 6)]);
    NE: canvas.Polyline([Point(FArrowPoint.x,     FArrowPoint.y),     Point(FArrowPoint.x, FArrowPoint.y + 6),
                         Point(FArrowPoint.x - 1, FArrowPoint.y + 6), Point(FArrowPoint.x - 1, FArrowPoint.y),
                         Point(FArrowPoint.x - 6, FArrowPoint.y),     Point(FArrowPoint.x - 6, FArrowPoint.y + 1),
                         Point(FArrowPoint.x - 2, FArrowPoint.y + 1), Point(FArrowPoint.x - 2, FArrowPoint.y + 4),
                         Point(FArrowPoint.x - 5, FArrowPoint.y + 7), Point(FArrowPoint.x - 6, FArrowPoint.y + 7),
                         Point(FArrowPoint.x - 3, FArrowPoint.y + 4), Point(FArrowPoint.x - 3, FArrowPoint.y + 3),
                         Point(FArrowPoint.x - 6, FArrowPoint.y + 6), Point(FArrowPoint.x - 7, FArrowPoint.y + 6),
                         Point(FArrowPoint.x - 3, FArrowPoint.y + 2), Point(FArrowPoint.x - 4, FArrowPoint.y + 2),
                         Point(FArrowPoint.x - 7, FArrowPoint.y + 5), Point(FArrowPoint.x - 7, FArrowPoint.y + 6)]);
    SW: canvas.Polyline([Point(FArrowPoint.x,     FArrowPoint.y),     Point(FArrowPoint.x, FArrowPoint.y - 6),
                         Point(FArrowPoint.x + 1, FArrowPoint.y - 6), Point(FArrowPoint.x + 1, FArrowPoint.y),
                         Point(FArrowPoint.x + 6, FArrowPoint.y),     Point(FArrowPoint.x + 6, FArrowPoint.y - 1),
                         Point(FArrowPoint.x + 2, FArrowPoint.y - 1), Point(FArrowPoint.x + 2, FArrowPoint.y - 4),
                         Point(FArrowPoint.x + 5, FArrowPoint.y - 7), Point(FArrowPoint.x + 6, FArrowPoint.y - 7),
                         Point(FArrowPoint.x + 3, FArrowPoint.y - 4), Point(FArrowPoint.x + 3, FArrowPoint.y - 3),
                         Point(FArrowPoint.x + 6, FArrowPoint.y - 6), Point(FArrowPoint.x + 7, FArrowPoint.y - 6),
                         Point(FArrowPoint.x + 3, FArrowPoint.y - 2), Point(FArrowPoint.x + 4, FArrowPoint.y - 2),
                         Point(FArrowPoint.x + 7, FArrowPoint.y - 5), Point(FArrowPoint.x + 7, FArrowPoint.y - 6)]);
    SE: canvas.Polyline([Point(FArrowPoint.x,     FArrowPoint.y),     Point(FArrowPoint.x, FArrowPoint.y - 6),
                         Point(FArrowPoint.x - 1, FArrowPoint.y - 6), Point(FArrowPoint.x - 1, FArrowPoint.y),
                         Point(FArrowPoint.x - 6, FArrowPoint.y),     Point(FArrowPoint.x - 6, FArrowPoint.y - 1),
                         Point(FArrowPoint.x - 2, FArrowPoint.y - 1), Point(FArrowPoint.x - 2, FArrowPoint.y - 4),
                         Point(FArrowPoint.x - 5, FArrowPoint.y - 7), Point(FArrowPoint.x - 6, FArrowPoint.y - 7),
                         Point(FArrowPoint.x - 3, FArrowPoint.y - 4), Point(FArrowPoint.x - 3, FArrowPoint.y - 3),
                         Point(FArrowPoint.x - 6, FArrowPoint.y - 6), Point(FArrowPoint.x - 7, FArrowPoint.y - 6),
                         Point(FArrowPoint.x - 3, FArrowPoint.y - 2), Point(FArrowPoint.x - 4, FArrowPoint.y - 2),
                         Point(FArrowPoint.x - 7, FArrowPoint.y - 5), Point(FArrowPoint.x - 7, FArrowPoint.y - 6)]);
  end;

  // DrawHintText
  canvas.brush.Style := bsClear;
  InflateRect(TextRect, -3, -1);
  {$IFDEF DFS_COMPILER_4_UP}
  if BidiMode = bdRightToLeft then
    DrawText(canvas.handle, PChar(Caption), Length(Caption), TextRect, DT_RIGHT or DT_WORDBREAK or DT_NOPREFIX)
  else
    DrawText(canvas.handle, PChar(Caption), Length(Caption), TextRect, DT_WORDBREAK or DT_NOPREFIX);
  {$ELSE}
  DrawText(canvas.handle, PChar(Caption), Length(Caption), TextRect, DT_WORDBREAK or DT_NOPREFIX);
  {$ENDIF}
end;

procedure TDefineHintWindow.ActivateHint (HintRect: TRect; const AHint: string);
var
  curWidth: Byte;
  Pnt: TPoint;
  HintHeight, HintWidth: Integer;
  NordWest, NordEast, SouthWest, SouthEast: TRect;
begin
  Caption := AHint;
  FHint   := FindFlatHint;

  if FHint <> nil then
    Canvas.Font.Assign(FHint.Font);

  // Calculate width and height
  HintRect.Right := HintRect.Left + FHint.MaxWidth - 22;

  {$IFDEF DFS_COMPILER_4_UP}
  if BidiMode = bdRightToLeft then
    DrawText(Canvas.Handle, @AHint[1], Length(AHint), HintRect, DT_RIGHT or DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX)
  else
    DrawText(Canvas.Handle, @AHint[1], Length(AHint), HintRect, DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX);
  {$ELSE}
  DrawText(Canvas.Handle, @AHint[1], Length(AHint), HintRect, DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX);
  {$ENDIF}


  DrawText(Canvas.Handle, @AHint[1], Length(AHint), HintRect, DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX);
  Inc(HintRect.Right, 22);
  Inc(HintRect.Bottom, 6);

  // Divide the screen in 4 pices
  NordWest :=  Rect(0, 0, Screen.Width div 2, Screen.Height div 2);
  NordEast :=  Rect(Screen.Width div 2, 0, Screen.Width, Screen.Height div 2);
  SouthWest := Rect(0, Screen.Height div 2, Screen.Width div 2, Screen.Height);
  SouthEast := Rect(Screen.Width div 2, Screen.Height div 2, Screen.Width, Screen.Height);

  GetCursorPos(Pnt);

  if PtInRect(NordWest, Pnt) then
    FArrowPos := NW
  else
    if PtInRect(NordEast, Pnt) then
      FArrowPos := NE
    else
      if PtInRect(SouthWest, Pnt) then
        FArrowPos := SW
      else
        FArrowPos := SE;

  // Calculate the position of the hint
  if FArrowPos = NW then
    curWidth := 12
  else
    curWidth := 5;

  HintHeight := HintRect.Bottom - HintRect.Top;
  HintWidth  := HintRect.Right - HintRect.Left;

  case FArrowPos of
    NW: HintRect := Rect(Pnt.x + curWidth, Pnt.y + curWidth, Pnt.x + HintWidth + curWidth, Pnt.y + HintHeight + curWidth);
    NE: HintRect := Rect(Pnt.x - HintWidth - curWidth, Pnt.y + curWidth, Pnt.x - curWidth, Pnt.y + HintHeight + curWidth);
    SW: HintRect := Rect(Pnt.x + curWidth, Pnt.y - HintHeight - curWidth, Pnt.x + HintWidth + curWidth, Pnt.y - curWidth);
    SE: HintRect := Rect(Pnt.x - HintWidth - curWidth, Pnt.y - HintHeight - curWidth, Pnt.x - curWidth, Pnt.y - curWidth);
  end;

  BoundsRect := HintRect;

  Pnt := ClientToScreen(Point(0, 0));

  SetWindowPos(Handle, HWND_TOPMOST, Pnt.X, Pnt.Y, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;

{ TBaseWater }

constructor TBaseWater.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 50;
{$IFDEF MSWINDOWS}
  FHandle := Classes.AllocateHWnd(WndProc);
{$ENDIF}
{$IFDEF LINUX}
  FHandle := WinUtils.AllocateHWnd(WndProc);
{$ENDIF}
end;

destructor TBaseWater.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
{$IFDEF MSWINDOWS}
  Classes.DeallocateHWnd(FHandle);
{$ENDIF}
{$IFDEF LINUX}
  WinUtils.DeallocateHWnd(FHandle);
{$ENDIF}
  inherited Destroy;
end;

procedure TBaseWater.WndProc(var Msg: TMessage);
begin
  with Msg do
    if Msg = WM_TIMER then
      try
        Timer;
      except
        Application.HandleException(Self);
      end
    else
      Result := DefWindowProc(FHandle, Msg, wParam, lParam);
end;

procedure TBaseWater.UpdateTimer;
begin
  KillTimer(FHandle, 1);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
    if SetTimer(FHandle, 1, FInterval, nil) = 0 then
      raise EOutOfResources.Create(SNoTimers);
end;

procedure TBaseWater.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TBaseWater.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TBaseWater.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TBaseWater.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

{ TDefineWater }
const
  RAND_MAX = $7FFF;

constructor TDefineWater.Create(AOwner: TComponent);
begin
  FBitmap    := TBitmap.Create;
  FWater     := TDefineWatet.Create;
  FItems     := TStringList.Create;
  inherited Create(AOwner);
  FDamping   := csDefDamping;
  FPlayState := true;
  OnTimer    := Play;
end;

destructor TDefineWater.Destroy;
begin
  FItems.Free;
  FWater.Free;
  FBitmap.Free;
  inherited Destroy;
end;

procedure TDefineWater.OnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  FWater.Blob(x,y,1,5000);
end;

procedure TDefineWater.SetDamping(Value: TWaterDamping);
begin
  if (Value >= Low(TWaterDamping)) and (Value <= High(TWaterDamping)) then
  begin
    FDamping       := Value;
    FWater.Damping := Value;
  end;
end;

procedure TDefineWater.InitiateWater;
var inx:Integer;
    TitleValue:String;
begin
  FBitmap.Assign(FImage.Bitmap);
  FImage.OnMouseMove := OnMouseMove;
  with FImage do
  begin
   Bitmap.FreeImage;
   Bitmap.Width  := FBitmap.Width;
   Bitmap.Height := FBitmap.Height;
  end;
  FWater.SetSize(FBitmap);
  FState      := FBitmap.Height;
  FPlayState  := false;
  FMoveHeight := 10;
  for inx := 0 to FItems.Count - 1 do
  begin
      TitleValue := FItems.Strings[inx];
      GetTitleParam(FParam, TitleValue);
      with FImage.Canvas do
      begin
       Font.Name   := FParam.Name;
       Font.Size   := FParam.Size;
       Font.Style  := FParam.Style;
       Font.Pitch  := FParam.Pitch;
       FMoveHeight := FMoveHeight + TextHeight(TitleValue)+FParam.Row;
      end;
  end;
  if FMoveHeight < FImage.Height then
     FMoveHeight := FImage.Height+10;
end;

procedure TDefineWater.Play;
var
  TitleValue:String;
  Inx,Cur: Integer;
begin
  if (FImage <> nil)and(not(csDesigning in ComponentState)) then
  begin
  if FPlayState then
     InitiateWater;
  if Random(8)= 1 then
     FWater.Blob(-1,-1,Random(1)+1,Random(500)+50);
  FWater.Render(Bitmap,FImage.Bitmap);
  FState:=FState-1;
  if FState<-FMoveHeight then
     FState:=FImage.height+10;
  with FImage.Canvas do
    begin
      Brush.Style:=bsClear;
      Cur := FState;
      for inx:=0 to FItems.Count - 1 do
      begin
       TitleValue := FItems.Strings[inx];
       GetTitleParam(FParam, TitleValue);
       Font.Name  := FParam.Name;
       Font.Size  := FParam.Size;
       Font.Style := FParam.Style;
       Font.Pitch := FParam.Pitch;
       if FParam.Draw3D then
       begin
          Font.Color := 0;
          case FParam.Align of
           wpLeft  :TextOut(21,Cur,TitleValue);
           wpCenter:TextOut((FImage.Width - TextWidth(TitleValue))div 2+1,Cur,TitleValue);
           wpRight :TextOut((FImage.Width - TextWidth(TitleValue))-21,Cur,TitleValue);
          end;
       end;
       Font.Color := FParam.Color;
       case FParam.Align of
        wpLeft  :TextOut(20,Cur,TitleValue);
        wpCenter:TextOut((FImage.Width - TextWidth(TitleValue))div 2,Cur,TitleValue);
        wpRight :TextOut((FImage.Width - TextWidth(TitleValue))-20,Cur,TitleValue);
       end;
       Cur := Cur+TextHeight('H')+FParam.Row;
      end;
      if FItems.Count <= 0 then
      begin
         TextOut((FImage.Width - TextWidth(''))div 2,Cur,'');
      end;
    end;
  end;
end;

procedure TDefineWater.SetItems(const Value: TStringList);
begin
  FItems.Assign(Value);
end;

procedure TDefineWater.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and (AComponent <> nil) then
  begin
    if AComponent=FImage then CtrlImage:=nil;
  end;
end;

{ TDefineImage }

constructor TDefineImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle       := ControlStyle + [csReplicatable];
  FEnterImage        := TBitmap.Create;
  FLeaveImage        := TBitmap.Create;
  FMouseState        := True;
  FAutoImage         := False;
  FAutoCursor        := crHandPoint;
  FAutoShowCursor    := false;
  FBitmap            := TBitmap.Create;
  FBitmap.OnChange   := PictureChanged;
  FBitmap.OnProgress := Progress;
  Height := 105;
  Width := 105;
end;

destructor TDefineImage.Destroy;
begin
  FEnterImage.Free;
  FLeaveImage.Free;
  FBitmap.Free;
  inherited Destroy;
end;

function TDefineImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FBitmap <> nil then
	Result := FBitmap.Palette;
end;

function TDefineImage.DestRect: TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
begin
  w  := Bitmap.Width;
  h  := Bitmap.Height;
  cw := ClientWidth;
  ch := ClientHeight;
  if Stretch or (Proportional and ((w > cw) or (h > ch))) then
  begin
	if Proportional and (w > 0) and (h > 0) then
	begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then  // woops, too big
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then  // woops, too big
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with Result do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Center then
	OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;

procedure TDefineImage.Paint;
var
  Save: Boolean;
begin
  if csDesigning in ComponentState then
	with inherited Canvas do
	begin
	  Pen.Style   := psDash;
	  Brush.Style := bsClear;
	  Rectangle(0, 0, Width, Height);
	end;
  Save     := FDrawing;
  FDrawing := True;
  try
	with inherited Canvas do
  begin
     StretchDraw(DestRect, Bitmap);
  end;
  finally
	FDrawing := Save;
  end;
end;

function TDefineImage.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp    := Bitmap;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
	(Tmp.PaletteModified) then
  begin
	if (Tmp.Palette = 0) then
	  Tmp.PaletteModified := False
	else
	begin
	  ParentForm := GetParentForm(Self);
	  if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
	  begin
		if FDrawing then
		  ParentForm.Perform(wm_QueryNewPalette, 0, 0)
		else
		  PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
		Result := True;
		Tmp.PaletteModified := False;
	  end;
	end;
  end;
end;

procedure TDefineImage.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if FIncrementalDisplay and RedrawNow then
  begin
	if DoPaletteChange then Update
	else Paint;
  end;
  if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;

function TDefineImage.GetCanvas: TCanvas;
var
  fBit: TBitmap;
begin
  if Bitmap = nil then
  begin
	fBit := TBitmap.Create;
	try
	  fBit.Width    := Width;
	  fBit.Height   := Height;
	  fBit          := Bitmap;
	finally
	  fBit.Free;
	end;
  end;
  if Bitmap is TBitmap then
	   Result := TBitmap(Bitmap).Canvas
  else
	raise EInvalidOperation.Create(SImageCanvasNeedsBitmap);
end;

procedure TDefineImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
	FCenter := Value;
	PictureChanged(Self);
  end;
end;

procedure TDefineImage.SetPicture(Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TDefineImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
	FStretch := Value;
	PictureChanged(Self);
  end;
end;

procedure TDefineImage.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
	 FTransparent := Value;
	 PictureChanged(Self);
  end;
end;

procedure TDefineImage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
	FProportional := Value;
	PictureChanged(Self);
  end;
end;

procedure TDefineImage.PictureChanged(Sender: TObject);
var
  G: TGraphic;
  D : TRect;
begin
  if AutoSize and (Bitmap.Width > 0) and (Bitmap.Height > 0) then
	SetBounds(Left, Top, Bitmap.Width, Bitmap.Height);
  G := Bitmap;
  if G <> nil then
  begin
	if not ((G is TMetaFile) or (G is TIcon)) then
	  G.Transparent := FTransparent;
  D := DestRect;
	if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and
	   (D.Right >= Width) and (D.Bottom >= Height) then
	  ControlStyle := ControlStyle + [csOpaque]
	else  // picture might not cover entire clientrect
	  ControlStyle := ControlStyle - [csOpaque];
	if DoPaletteChange and FDrawing then Update;
  end
  else ControlStyle := ControlStyle - [csOpaque];
  if not FDrawing then Invalidate;
end;

function TDefineImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or (Bitmap.Width > 0) and
    (Bitmap.Height > 0) then
  begin
    if Align in [alNone, alLeft, alRight] then
       NewWidth := Bitmap.Width;
    if Align in [alNone, alTop, alBottom] then
       NewHeight := Bitmap.Height;
  end;
end;

procedure TDefineImage.MouseEnter(var Msg: TMessage);
begin
if not(csDesigning in ComponentState) then
begin
 if FAutoImage and FMouseState Then
  begin
    Bitmap.Assign(FEnterImage);
    FMouseState := False;
  end;
 If FAutoShowCursor Then
    Cursor := FAutoCursor;
end;
end;

procedure TDefineImage.MouseLeave(var Msg: TMessage);
begin
if not(csDesigning in ComponentState) then
begin
 if FAutoImage and not FMouseState Then
  begin
    Bitmap.Assign(FLeaveImage);
    FMouseState := True;
  end;
end;
end;

procedure TDefineImage.SetEnterImage(const Value: TBitmap);
begin
  FEnterImage.Assign(Value);
end;

procedure TDefineImage.SetLeaveImage(const Value: TBitmap);
begin
  FLeaveImage.Assign(Value);
end;

initialization
  OwnerList := TList.Create;

finalization
  OwnerList.Free;


end.