formcont.pas

delphi2007界面效果控件源码

unit FormCont;

interface

{$INCLUDE teDefs.inc}

uses
  SysUtils, Classes, consts, TransEff, teBkgrnd, teRender, ActnList, Windows,
  Messages, Forms, Graphics, Controls, StdCtrls;

type
  TFCFormAlign = (fcfaDefault, fcfaNone, fcfaCenter, fcfaClient, fcfaTopLeft,
    fcfaMainFormCenter);

  TFCFormChangeEvent = procedure(Sender: TObject;
    const OldForm, NewForm: TCustomForm; var CanChange: Boolean) of object;
  TFCFormCreateEvent = procedure(Sender: TObject;
    const Form: TCustomForm) of object;
  TFCFormDestroyEvent = procedure(Sender: TObject;
    const Form: TCustomForm) of object;

  EFormContainerError = class(Exception);

  TFCExtraData = class
  end;

  TFCExtraDataClass = class of TFCExtraData;

  TFCGetExtraDataClass = function: TFCExtraDataClass        of object;
  TFCGetExtraData      = procedure(ExtraData: TFCExtraData) of object;
  TFCSetExtraData      = procedure(ExtraData: TFCExtraData) of object;

  TFCFormData = class
  private
    FFormClass: TCustomFormClass;
    FForm: TCustomForm;

    FOnHide: TNotifyEvent;
    FOnShow: TNotifyEvent;
  protected
    DoneShow: Boolean;

    procedure ReadData(AForm: TCustomForm);
    procedure DoHide;
    procedure DoShow;
  public
    FAlign: TFCFormAlign;
    FPosition: TPosition;
    FBorderIcons: TBorderIcons;
    FDescription: String;
    FExtraData: TFCExtraData;

    constructor Create(AForm: TCustomForm);
    destructor  Destroy; override;

    property Align: TFCFormAlign read FAlign write FAlign;
    property Position: TPosition read FPosition write FPosition;
    property BorderIcons: TBorderIcons read FBorderIcons write FBorderIcons;
    property Description: String read FDescription write FDescription;
    property ExtraData: TFCExtraData read FExtraData write FExtraData;
    property FormClass: TCustomFormClass read FFormClass;
    property Form: TCustomForm read FForm;
  end;

  TFormContainer = class(TScrollingWinControl)
  private
    FCanvas: TCanvas;
    FBackgroundOptions: TFCBackgroundOptions;
    FBorderStyle: TBorderStyle;
    FFlickerFree,
    DoCheckOnClose: Boolean;
    FForm: TCustomForm;
    FForms: TList;
    AllFormsData: TList;
    Locked: Boolean;
    FLRUForms: TList;
    FLRUFormIndex,
    NewLRUFormIndex,
    FLRUFormCapacity: Integer;
    FSaveLRUDestroyedForms: Boolean;
    FSafeFormDestroy: Boolean;
    FOnFormChange: TFCFormChangeEvent;
    FOnFormCreate: TFCFormCreateEvent;
    FOnFormDestroy: TFCFormDestroyEvent;

    procedure SetBackgroundOptions(Value: TFCBackgroundOptions);
    procedure SetBorderStyle(Value: TBorderStyle);
    function  GetForms(Index: Integer): TCustomForm;
    procedure SetForm(Value: TCustomForm; DestroyCurrent: Boolean);
    function  GetFormData(Index: Integer): TFCFormData;
    function  GetLRUForm(Index: Integer): TCustomForm;
    function  GetLRUFormData(Index: Integer): TFCFormData;
    procedure SetLRUFormCapacity(Value: Integer);
    function  GetPicture: TPicture;
    procedure SetPicture(const Value: TPicture);
    function  GetVersion: String;
    procedure SetVersion(const Value: String);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  protected
    function  GetFormAlignToUse(Form: TCustomForm): TFCFormAlign;
    procedure AdjustForm(CheckVisible: Boolean); virtual;
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    function  CheckFormsData: Boolean;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DestroyingLRUForm(FormData: TFCFormData);
    procedure DeleteFormData(FData: TFCFormData);
    function  DeleteLRUForm(F: TCustomForm): Boolean;
    function  DeleteLRUFormByIndex(Index: Integer): Boolean;
    function  FormAlign: TFCFormAlign;
    function  GetPalette: HPalette; override;
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
{$ifndef D9UP}
    procedure AddActionList(ActionList: TCustomActionList);
    procedure RemoveActionList(ActionList: TCustomActionList);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
{$endif D9UP}
    procedure SetName(const NewName: TComponentName); override;
    procedure SetParent(AParent: TWinControl); override;

    property  Canvas: TCanvas read FCanvas;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;

    function  FormCount: Integer;
    function  LRUFormCount: Integer;
    function  CloseQuery: Boolean;
    function  CloseQueryAll: Boolean;
    function  FormData: TFCFormData;
    function  IndexOf(Value: TCustomForm): Integer;
    function  CheckOnClose(Default: Boolean): Boolean;
    procedure ClearLRUHistory;
    function  CreateForm(AClass: TCustomFormClass): TCustomForm;
    function  CreateShowForm(AClass: TCustomFormClass;
      DestroyCurrent: Boolean = True): TCustomForm;
    function  CreateShowFormEx(AClass: TCustomFormClass;
      DestroyCurrent: Boolean = True;
      Transition: TTransitionEffect = nil;
      BackgrOptions: TFCBackgroundOptions = nil;
      Align: TFCFormAlign = fcfaDefault): TCustomForm;
    procedure ShowForm(AForm: TCustomForm;
      DestroyCurrent: Boolean = True);
    procedure ShowFormEx(AForm: TCustomForm = nil;
      DestroyCurrent: Boolean = True;
      Transition: TTransitionEffect = nil;
      BackgrOptions: TFCBackgroundOptions = nil;
      Align: TFCFormAlign = fcfaDefault);
    function ShowLRUForm(Index: Integer;
      DestroyCurrent: Boolean = True): Boolean;
    function ShowLRUFormEx(Index: Integer;
      DestroyCurrent: Boolean = True;
      Transition: TTransitionEffect = nil;
      BackgrOptions: TFCBackgroundOptions = nil;
      Align: TFCFormAlign = fcfaDefault): Boolean;
    function  HasNextLRUForm: Boolean;
    function  HasPriorLRUForm: Boolean;
    function  ShowNextLRUForm(DestroyCurrent: Boolean = True): Boolean;
    function  ShowNextLRUFormEx(DestroyCurrent: Boolean = True;
      Transition: TTransitionEffect = nil;
      BackgrOptions: TFCBackgroundOptions = nil;
      Align: TFCFormAlign = fcfaDefault): Boolean;
    function  ShowPriorLRUForm(DestroyCurrent: Boolean = True): Boolean;
    function  ShowPriorLRUFormEx(DestroyCurrent: Boolean = True;
      Transition: TTransitionEffect = nil;
      BackgrOptions: TFCBackgroundOptions = nil;
      Align: TFCFormAlign = fcfaDefault): Boolean;
    procedure DestroyForm(F: TCustomForm);
    procedure DestroyAllForms;

    property  Form: TCustomForm read FForm;
    property  Forms[Index: Integer]: TCustomForm read GetForms; default;
    property  FormsData[Index: Integer]: TFCFormData read GetFormData;
    property  LRUFormIndex: Integer read FLRUFormIndex;
    property  LRUForms[Index: Integer]: TCustomForm read GetLRUForm;
    property  LRUFormsData[Index: Integer]: TFCFormData read GetLRUFormData;
  published
    property  Align;
    property  AutoScroll default False;
    property  BackgroundOptions: TFCBackgroundOptions read FBackgroundOptions write SetBackgroundOptions;
    property  BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
    property  DragCursor;
    property  DragMode;
    property  Enabled;
    property  Color nodefault;
    property  Ctl3D;
    property  FlickerFree: Boolean read FFlickerFree write FFlickerFree default True;
    property  Font;
    property  HorzScrollBar;
    property  LRUFormCapacity: Integer read FLRUFormCapacity write SetLRUFormCapacity default 20;
    property  OnClick;
    property  OnDblClick;
    property  OnDragDrop;
    property  OnDragOver;
    property  OnEndDrag;
    property  OnEnter;
    property  OnExit;
    property  OnFormChange: TFCFormChangeEvent read FOnFormChange write FOnFormChange;
    property  OnFormCreate: TFCFormCreateEvent read FOnFormCreate write FOnFormCreate;
    property  OnFormDestroy: TFCFormDestroyEvent read FOnFormDestroy write FOnFormDestroy;
    property  OnMouseDown;
    property  OnMouseMove;
    property  OnMouseUp;
    {$ifdef D7UP}
    property  ParentBackground;
    {$endif D7UP}
    property  ParentColor;
    property  ParentCtl3D;
    property  ParentFont;
    property  ParentShowHint;
    property  Picture: TPicture read GetPicture write SetPicture stored False; // For backwards compatibility with V1.x
    property  PopupMenu;
    property  SafeFormDestroy: Boolean read FSafeFormDestroy write FSafeFormDestroy default True;
    property  SaveLRUDestroyedForms: Boolean read FSaveLRUDestroyedForms write FSaveLRUDestroyedForms default False;
    property  ShowHint;
    property  TabOrder;
    property  TabStop;
    property  Version: String read GetVersion write SetVersion stored False;
    property  VertScrollBar;
    property  Visible;
    property  Anchors;
    property  BevelEdges;
    property  BevelInner;
    property  BevelOuter;
    property  BevelKind;
    property  BevelWidth;
    property  BiDiMode;
    property  BorderWidth;
    property  Constraints;
    property  DragKind;
    property  ParentBiDiMode;
    property  OnEndDock;
    property  OnStartDock;
    property  OnStartDrag;
  end;

  TFCGetExtraDataClassEvent = procedure(Sender: TObject;
    var ExtraDataClass: TFCExtraDataClass) of object;
  TFCExtraDataEvent = procedure(Sender: TObject;
    ExtraData: TFCExtraData) of object;

  TFCEmbeddedForm = class(TCustomForm)
  private
    FBackgroundOptions: TFCBackgroundOptions;
    FOnGetExtraDataClass: TFCGetExtraDataClassEvent;
    FOnGetExtraData,
    FOnSetExtraData: TFCExtraDataEvent;
    FAlignment: TFCFormAlign;

    function  GetVersion: String;
    procedure SetVersion(const Value: String);
    procedure SetBackgroundOptions(Value: TFCBackgroundOptions);

    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function  GetPalette: HPalette; override;
    procedure Paint; override;
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function    ParentFormContainer: TFormContainer;
  published
    // TCustomForm properties / events
    property Action;
    property ActiveControl;
    property BiDiMode;
    property Caption;
    property ClientHeight stored True;
    property ClientWidth stored True;
    property Color;
    property Ctl3D;
    property UseDockManager;
    property DockSite;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentFont default False;
    property Font;
    property Height stored False;
    property HelpFile;
    property KeyPreview;
    property Menu;
    property OldCreateOrder;
    property ObjectMenuItem;
    {$ifdef D7UP}
    property  ParentBackground;
    {$endif D7UP}
    property ParentBiDiMode;
    property ParentColor;
    property ParentShowHint;
    property PixelsPerInch;
    property PopupMenu;
    property Scaled;
    property ShowHint;
    property Width stored False;
    property OnCanResize;
    property OnClick;
    property OnClose;
    property OnCloseQuery;
    property OnConstrainedResize;
    {$ifdef D6}
    property OnContextPopup;
    {$endif D6}
    property OnCreate;
    property OnDblClick;
    property OnDestroy;
    property OnDockDrop;
    property OnDockOver;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnGetSiteInfo;
    property OnHide;
    property OnHelp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnPaint;
    property OnResize;
    property OnShortCut;
    property OnShow;
    property OnStartDock;
    property OnUnDock;

    // Added properties / events
    property Alignment: TFCFormAlign read FAlignment write FAlignment default fcfaCenter;
    property BackgroundOptions: TFCBackgroundOptions read FBackgroundOptions write SetBackgroundOptions;
    property Version: String read GetVersion write SetVersion stored False;

    property OnEnter;
    property OnExit;

    property OnGetExtraDataClass: TFCGetExtraDataClassEvent read FOnGetExtraDataClass write FOnGetExtraDataClass;
    property OnGetExtraData: TFCExtraDataEvent read FOnGetExtraData write FOnGetExtraData;
    property OnSetExtraData: TFCExtraDataEvent read FOnSetExtraData write FOnSetExtraData;
  end;

  procedure FCKeyPreview(WinControl: TWinControl; var Key: Word;
    Shift: TShiftState);
  procedure FCIsShortCut(WinControl: TWinControl; var Msg: TWMKey;
    var Handled: Boolean);

implementation

{$ifdef D7UP}
uses Themes, UxTheme;
{$endif D7UP}

resourcestring
  rsFCLockedFormCont = 'FomContainer is locked';
  rsFCUnknownForm    = 'Form ''%s'' unknown';
  rsFCBorderStyle    = '''BorderStyle'' property of ''%s'' must be ''bsNone''';
  rsFCVisible        = '''Visible'' property of ''%s'' must be ''False'' at design time';
  rsFCState          = '''WindowState'' property of ''%s'' must be ''wsNormal''';
  rsFCStyle          = '''FormStyle'' property of ''%s'' must be ''fsNormal''';

type
  TFCCustomForm = class(TCustomForm);
  TFCWinControl = class(TWinControl);

  TFCOnFormDestroyData = class
  public
    Form: TCustomForm;
    OnFormDestroyBack: TNotifyEvent;

    procedure OnFormDestroy(Sender: TObject);
  end;

var
  OnFormDestroyList: TList = nil;

procedure HideEmbeddedForms(WinControl: TWinControl);
var
  i: Integer;
begin
  for i:=WinControl.ControlCount-1 downto 0 do
  begin
    if WinControl.Controls[i] is TWinControl then
      HideEmbeddedForms(WinControl.Controls[i] as TWinControl);
  end;

  if(WinControl is TFormContainer)             and
    (TFormContainer(WinControl).FormCount > 0) then
    (WinControl as TFormContainer).ShowForm(nil, False);
end;

function GetOnFormDestroyData(Form: TCustomForm): TFCOnFormDestroyData;
var
  i: Integer;
begin
  Result := nil;

  if OnFormDestroyList = nil then
    Exit;

  for i:=0 to OnFormDestroyList.Count-1 do
  begin
    if TFCOnFormDestroyData(OnFormDestroyList[i]).Form = Form then
    begin
      Result := TFCOnFormDestroyData(OnFormDestroyList[i]);
      Break;
    end;
  end;
end;

procedure FCKeyPreview(WinControl: TWinControl; var Key: Word;
  Shift: TShiftState);
var
  i: Integer;
  ChildWinControl: TWinControl;
begin
  if Key <> 0 then
  begin
    for i:= 0 to WinControl.ControlCount-1 do
    begin
      if WinControl.Controls[i] is TWinControl then
      begin
        ChildWinControl := TWinControl(WinControl.Controls[i]);
        if ChildWinControl.Visible then
        begin
          FCKeyPreview(ChildWinControl, Key, Shift);
          if(ChildWinControl is TCustomForm)          and
            TCustomForm  (ChildWinControl).KeyPreview then
            TFCWinControl(ChildWinControl).KeyDown(Key, Shift);
        end;
      end;
    end;
  end;
end;

procedure FCIsShortCut(WinControl: TWinControl; var Msg: TWMKey;
 var Handled: Boolean);
var
 i: Integer;
 ChildWinControl: TWinControl;
begin
 for i:= 0 to WinControl.ControlCount-1 do
 begin
   if WinControl.Controls[i] is TWinControl then
   begin
     ChildWinControl := TWinControl(WinControl.Controls[i]);
     if ChildWinControl.Visible then
     begin
       FCIsShortCut(ChildWinControl, Msg, Handled);
       if WinControl.Controls[i] is TCustomForm then
         TFCCustomForm(WinControl.Controls[i]).OnShortCut(Msg,
           Handled);
     end;
   end;
 end;
end;

{ TFCFormData }
constructor TFCFormData.Create(AForm: TCustomForm);
begin
  FFormClass   := TCustomFormClass(AForm.ClassType);
  FAlign       := fcfaDefault;
  FPosition    := TFCCustomForm(AForm).Position;
  FBorderIcons := TFCCustomForm(AForm).BorderIcons;
  FExtraData   := nil;

  ReadData(AForm);
end;

destructor TFCFormData.Destroy;
begin
  ExtraData.Free;

  inherited;
end;

procedure TFCFormData.ReadData(AForm: TCustomForm);
begin
  DoneShow    := False;
  FForm       := AForm;
  Description := AForm.Caption;

  if Assigned(TFCCustomForm(AForm).OnHide) then
  begin
    FOnHide := TFCCustomForm(AForm).OnHide;
    TFCCustomForm(AForm).OnHide := nil;
  end;

  if Assigned(TFCCustomForm(AForm).OnShow) then