terollform.pas

这个东西的功能很强大

    FOldCaption: string;
    FChanging: boolean;
    FTrayMsgWindow: HWnd;
    FOldApplicationRestore: TNotifyEvent;
    FOldApplicationMinimize: TNotifyEvent;
    FSetAppEvent: boolean;
    FIcon: TIcon;
    FAllowDraw: boolean;
    FFormActive: boolean;
    FDownHitTest: TTeWindowHitTest;
    FMoveHitTest: TTeWindowHitTest;
    FWidth, FHeight: integer;
    FRealWidth, FRealHeight: integer;
    FShift: TShiftState;
    FOldClientProc: TFarProc;
    FClientInstance: TFarProc;
    FOldRect: TRect;
    FNoCopyScreen: boolean;
    FAniBuffer: TTeBitmap;
    FDragged: boolean;
    FSimpleDrawRect: TRect;
    FSimpleDrawEnabled: boolean;
    FSaveMode: TTeFormDragMode;
    FSavedClentSize: TPoint;
    FSavedOnShortCut: TShortCutEvent;
    FStretchBackground: boolean;
    FCaption: WideString;
    FBlending: TTeBlending;
    FShadow: TTeShadow;
    FGravitation: TTeGravitation;
    FDragging: TTeDragging;
    { Event }
    FOnPaint: TNotifyEvent;
    FOnMinimize: TTeFormActionEvent;
    FOnClose: TTeFormActionEvent;
    FOnMaximize: TTeFormActionEvent;
    FOnMinToTray: TTeFormActionEvent;
    FOnRollup: TTeFormActionEvent;
    FSystemMenuLink: TPopupMenu;
    FTrayMenuLink: TPopupMenu;
    FOnCreate: TNotifyEvent;
    FOnResize: TNotifyEvent;
    FWindowMenu: TTeItem;
    FWindowMenuHandling: boolean;
    { MDI }
    FSaveMDIRect: TRect;
    FSaveMDIConstraints: TSizeConstraints;
    FVScroll: TGraphicControl;
    FVContainer: TWinControl;
    FHScroll: TGraphicControl;
    FHContainer: TWinControl;
    FGripperRect: TRect;
    { Drawing }
    FClipDraw: boolean;
    FClipRect: TRect;
    { Drawing and blending }
    function ApplyGravitation(R: TRect): TRect;
    procedure CopyScreen(NewRect: TRect);
    procedure DrawDragFrame(R: TRect);
    { Drawing }
    procedure DrawCaptionButton(Canvas: TCanvas; R: TRect; Kind: TTeBorderIcon; Pressed, Hover: boolean);
    procedure DrawCaption(Canvas: TCanvas);
    { Anmation }
    procedure AnimationShow;
    { MDI }
    procedure ClientWndProc(var Message: TMessage);
    procedure RestoreMDIChildren;
    procedure SaveAllMDIChildren;
    procedure ScrollBarUpdate;
    { Events }
    procedure DoApplicationMinimize(Sender: TObject);
    procedure DoApplicationRestore(Sender: TObject);
    procedure DoSysMenu(Sender: TObject);
    procedure DoFormShortCut(var Msg: TWMKey; var Handled: Boolean);
    procedure DoBlendingChanged(Sender: TObject);
    procedure DoShadowChanged(Sender: TObject);
    procedure DoWindowItemClick(Sender: TObject);
    procedure DoVScroll(Sender: TObject; ScrollCode: TTeScrollCode; var ScrollPos: Integer);
    procedure DoHScroll(Sender: TObject; ScrollCode: TTeScrollCode; var ScrollPos: Integer);
    { Tray }
    procedure MsgTrayWndProc(var Msg: TMessage);
    procedure EndSession;
    { KSDev's product compatible }
    procedure CMPaintToBitmap(var Msg: TMessage); message CM_PAINTTOBITMAP;
    { Windows Message Handlers }
    procedure WMMDIActivate(var Message: TWMMDIActivate); message WM_MDIACTIVATE;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;
    procedure WMNCLButtonDown(var Msg: TWMNCHitMessage); message WM_NCLBUTTONDOWN;
    procedure WMNCLButtonUp(var Msg: TWMNCHitMessage); message WM_NCLBUTTONUP;
    procedure WMNCLButtonDblClk(var Msg: TWMNCHitMessage); message WM_NCLBUTTONDBLCLK;
    procedure WMNCRButtonDown(var Msg: TWMNCHitMessage); message WM_NCRBUTTONDOWN;
    procedure WMNCRButtonUp(var Msg: TWMNCHitMessage); message WM_NCRBUTTONUP;
    procedure WMNCMouseMove(var Msg: TWMNCHitMessage); message WM_NCMOUSEMOVE;
    procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP;
    procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;
    procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMPaint(var Msg: TMessage); message WM_PAINT;
    procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
    procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
    { XP }
    procedure WMThemeChanged(var Msg: TMessage); message WM_THEMECHANGED;
    { Internal Event }
    procedure WMUpdateNonClientArea(var Msg: TMessage); message WM_UPDATENCAREA;
    procedure WMMaximize(var Msg: TMessage); message WM_MAXIMIZE;
    procedure WMStartAction(var Msg: TMessage); message WM_STARTACTION;
    { Propeties }
    procedure SetBorderStyle(const Value: TTeBorderStyle);
    procedure SetBorderIcons(const Value: TTeBorderIcons);
    procedure SetWindowState(const Value: TTeWindowState);
    procedure SetConstraints(const Value: TSizeConstraints);
    procedure SetStayOnTop(const Value: boolean);
    procedure SetPerformance(const Value: TTeFormPerformance);
    procedure SetStretchBackground(const Value: boolean);
    procedure SetCaption(const Value: WideString);
    procedure SetBlending(const Value: TTeBlending);
    procedure SetShadow(const Value: TTeShadow);
    procedure SetGravitation(const Value: TTeGravitation);
    procedure SetDragging(const Value: TTeDragging);
    procedure SetSystemMenuOptions(const Value: TTePopupMenuOptions);
    procedure SetTrayMenuOptions(const Value: TTePopupMenuOptions);
    procedure SetAnimation(const Value: TTeAnimation);
    procedure SetSystemMenuLink(const Value: TPopupMenu);
    procedure SetTrayMenuLink(const Value: TPopupMenu);
    procedure SetWindowMenu(const Value: TTeItem);
  protected
    { After form message }
    procedure DoBeforeDestruction; override;
    procedure DoAfterMessage(var Msg: TMessage; var Handled: Boolean); override;
    procedure SetActive(Value: Boolean); override;
    { Internal }
    procedure MoveWindow(OffsetX, OffsetY: integer); overload;
    procedure MoveWindow(Left, Top, Width, Height: integer); overload;
    procedure MoveWindow(Bounds: TRect); overload;
    procedure UpdateNonClientArea(ClipRgn: HRgn);
    procedure ChangeSize; virtual;
    function GetRegion: HRgn; virtual;
    function GetParentRect: TRect;
    function NormalizePoint(P: TPoint): TPoint;
    function GetGripperHitTest(X, Y: integer): TTeWindowHitTest;
    { MDI }
    function IsMDIChildMaximized: boolean;
    function GetMDIParentForm: TCustomForm;
    function GetMDIParentKsForm: TTeDefaultForm;
    procedure ChangeMDIParentCaption;
    { MenuBar and Sysmenu }
    procedure CreateSysMenu;
    function CreateMenuItem(AOwner: TComponent): TTeItem; virtual;
    { Protected Routines }
    function GetCaptionButtonRect(Button: TTeBorderIcon): TRect; virtual;
    function GetClientBounds: TRect; virtual; { Return ClientRect in non client origins }
    function GetClientRect: TRect;
    { WindowState's Rect }
    function GetRollupRect: TRect; virtual;
    function GetMinimizedRect: TRect; virtual;
    function GetMaximizedRect: TRect; virtual;
    { Tracking Size }
    function GetMaxTrackSize: TPoint; virtual;
    function GetMinTrackSize: TPoint; virtual;
    { Scrolling }
    function CreateScrollBar(AOwner: TComponent): TComponent; virtual;
    function GetGripperRect: TRect; virtual;
    procedure PaintGripper(Canvas: TCanvas); virtual;
    { Painting }
    procedure PaintNonClientArea(Canvas: TCanvas); virtual;
    procedure PaintClientArea; virtual;
    { Mouse Routines }
    procedure NCMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); dynamic;
    procedure NCMouseMove(Shift: TShiftState; X, Y: integer); dynamic;
    procedure NCMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); dynamic;

    function GetHitTest(X, Y: integer): TTeWindowHitTest; virtual;
    { VCL protected  }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    { Protected Properties }
    property Dragged: boolean read FDragged;
    property FormActive: boolean read FFormActive;
    property DownHitTest: TTeWindowHitTest read FDownHitTest;
    property MoveHitTest: TTeWindowHitTest read FMoveHitTest;
    property Shift: TShiftState read FShift;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Update;
    { Internal }
    function GetIcon: TIcon;
    procedure DisableDrawing;
    procedure EnableDrawing;
    { Invalidating }
    procedure InvalidateNow;
    procedure InvalidateRect(ARect: TRect);
    { MDI Routines }
    procedure UpdateWindowMenu;
    procedure Tile;
    procedure Cascade;
    { Tray }
    procedure UpdateTrayIcon;
    { Form's actions  }
    procedure Close;
    procedure Maximize;
    procedure Minimize;
    procedure Restore;
    procedure Help;
    procedure Rollup;
    procedure MinToTray;
    procedure SysMenu;
    { Public properies }
    property Canvas: TCanvas read FCanvas;
    property Width: integer read FWidth write FWidth;
    property Height: integer read FHeight write FHeight;
  published
    property Active;
    property Animation: TTeAnimation read FAnimation write SetAnimation;
    property Blending: TTeBlending read FBlending write SetBlending;
    property BorderIcons: TTeBorderIcons read FBorderIcons write SetBorderIcons;
    property BorderStyle: TTeBorderStyle read FBorderStyle write SetBorderStyle;
    property Caption: WideString read FCaption write SetCaption;
    property Dragging: TTeDragging read FDragging write SetDragging;
    property Gravitation: TTeGravitation read FGravitation write SetGravitation;
    property Constraints: TSizeConstraints read FConstraints write SetConstraints;
    property WindowMenu: TTeItem read FWindowMenu write SetWindowMenu;
    property SystemMenuOptions: TTePopupMenuOptions read FSystemMenuOptions write SetSystemMenuOptions;
    property SystemMenuLink: TPopupMenu read FSystemMenuLink write SetSystemMenuLink;
    property TrayMenuOptions: TTePopupMenuOptions read FTrayMenuOptions write SetTrayMenuOptions;
    property TrayMenuLink: TPopupMenu read FTrayMenuLink write SetTrayMenuLink;
    property MinimizeApplication: boolean read FMinimizeApplication write FMinimizeApplication default true;
    property Performance: TTeFormPerformance read FPerformance write SetPerformance;
    property Shadow: TTeShadow read FShadow write SetShadow;
    property StayOnTop: boolean read FStayOnTop write SetStayOnTop;
    property StretchBackground: boolean read FStretchBackground write SetStretchBackground;
    property WindowState: TTeWindowState read FWindowState write SetWindowState;
    { Events }
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnClose: TTeFormActionEvent read FOnClose write FOnClose;
    property OnMinimize: TTeFormActionEvent read FOnMinimize write FOnMinimize;
    property OnMaximize: TTeFormActionEvent read FOnMaximize write FOnMaximize;
    property OnRollup: TTeFormActionEvent read FOnRollup write FOnRollup;
    property OnMinToTray: TTeFormActionEvent read FOnMinToTray write FOnMinToTray;
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
  end;

{ TTeForm class }

  TTeForm = class(TTeDefaultForm)
  private
    FThemeObject: TTeThemeObject;
    procedure SetThemeObject(const Value: TTeThemeObject);
    { Theme Messages }
    procedure SNMThemeMessage(var Msg: TMessage); message SNM_THEMEMESSAGE;
  protected
    { protected Routines }
    function GetRegion: HRgn; override;
    function GetClientBounds: TRect; override;
    function GetCaptionButtonRect(Button: TTeBorderIcon): TRect; override;
    { WindowState's Rect }
    function GetRollupRect: TRect; override;
    function GetMinimizedRect: TRect; override;
    function GetMaximizedRect: TRect; override;
    { Tracking Size }
    function GetMaxTrackSize: TPoint; override;
    function GetMinTrackSize: TPoint; override;
    { Painting }
    procedure PaintNonClientArea(Canvas: TCanvas); override;
    procedure PaintClientArea; override;
    procedure PaintGripper(Canvas: TCanvas); override;
    { Mouse Routines }
    function GetHitTest(X, Y: integer): TTeWindowHitTest; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
    property ThemeObject: TTeThemeObject read FThemeObject write SetThemeObject;
  end;

const
  ActiveComboBox: Pointer = nil;
  DoCloseActiveComboBox: procedure (Sender: TObject) of object = nil;

var
  CaptionFont: TFont;
  SmCaptionFont: TFont;

function GetParentKsForm(Control: TControl): TTeForm;

function WindowButtons(Form: TTeDefaultForm): TTeWindowButtons;
function WindowStates(Form: TTeDefaultForm): TTeWindowDrawStates;
function WindowSubclass(Form: TTeDefaultForm): TTeWindowSubclass;

function DrawFormBackground(Canvas: TCanvas; Background: TTeBackground): boolean;


type

{$IFDEF KS_COMPILER5_UP}
  TTeFrame = class(TFrame)
  private
    procedure PerformEraseBackground(Control: TControl; DC: HDC);
    procedure PaintOwnerBackground(DC: HDC);

    procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMPaint(var Msg: TMessage); message WM_PAINT;
    { Private declarations }
  public
    { Public declarations }
  end;
{$ELSE}
  TTeFrame = class(TForm);
{$ENDIF}

const
  DefEditBtnWidth = 19;

  AlphaMask = $FF000000;

procedure FillLongword(var X; Count: Integer; Value: Longword);
procedure FillLongwordRect(var X; W,H,X1,Y1,X2,Y2 : Integer; Value: Longword);

procedure FillAlpha(var X; Count: Integer; Alpha: byte);
procedure FillAlphaRect(var X; W,H,X1,Y1,X2,Y2: Integer; Alpha: byte); assembler;

function BlendPixel(F, B: Longword): Longword;
procedure BlendLine(Src, Dst: Pointer; Count: Integer);

procedure ClearAlpha(var X; Count: integer; Value: longword);
function ColorSwap(WinColor: longword): longword;

function MulDiv16(Number, Numerator, Denominator: Word): Word;


procedure DoConvert(const ParentItem: TTeItem; const Menu: TMenu;
  const Owner: TComponent; ItemClass: TTeItemClass; Log: TStrings);


type

  TTePopupWindow = class;

{ TTePopupView }

  TTePopupView = class(TTeItemView)
  private
    FPopupWindow: TTePopupWindow;
  protected
    procedure SetSize(ASize: TPoint); override;
    procedure SetPosition(APosition: TPoint); override;
    procedure InvalidateView; override;
    procedure InvalidateItem(AItem: TTeItem); override;
    procedure InvalidateScrollButton(Button: TTeMenuScrollButton); override;
  public
    constructor