terollform.pas

这个东西的功能很强大

  TTeBevelSides = set of TTeBevelSide;
  TTeBevelKind = (kbkNone, kbkSingle, kbkTile, kbkSoft, kbkBorder, kbkFlat);

  { TTePerfomance set a buffer kind of a form. The following table lists the possible values:
    <TABLE>
    Value                       Meaning
    -----                       -------
    kspSharedBuffer             High speed - middle of memory. Shared buffer.
    kspDoubleBuffer             Slow speed - middle of memory.
    kspNoBuffer                 Max speed - min of memory. But flickers.
    </TABLE>
  }
  TTePerformance = (kspNoBuffer, kspSharedBuffer, kspDoubleBuffer);

  TTeScrollCode = (kscLineUp, kscLineDown, kscPageUp, kscPageDown, kscPosition, kscTrack,
    kscTop, kscBottom, kscEndScroll);
  TTeScrollEvent = procedure (Sender: TObject; ScrollCode: TTeScrollCode; var ScrollPos: Integer) of object;

{ TTeControl class }

  TTeControl = class(TCustomControl)
  private
    FPerformance: TTePerformance;
    FFocused: boolean;
    FMouseInControl: Boolean;
    FHScrollBar, FVScrollBar: TControl;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FScrollBars: TScrollStyle;
    FDisableScrollBarUpdate: boolean;
    FFont: TFont;
    FBorderWidth: integer;
    FBevelInner: TTeBevelCut;
    FBevelOuter: TTeBevelCut;
    FBevelSides: TTeBevelSides;
    FBevelKind: TTeBevelKind;
    FBevelWidth: integer;
    FDrawXPBorder: boolean;
    { Windows }
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    { XP }
    procedure WMThemeChanged(var Msg: TMessage); message WM_THEMECHANGED;
    { Properties }
    procedure SetScrollBars(const Value: TScrollStyle);
    procedure SetFont(const Value: TFont);
    procedure SetBorderWidth(const Value: integer);
    procedure SetBevelSides(const Value: TTeBevelSides);
    procedure SetBevelKind(const Value: TTeBevelKind);
    procedure SetBevelWidth(const Value: integer);
    procedure SetBevelInner(const Value: TTeBevelCut);
    procedure SetBevelOuter(const Value: TTeBevelCut);
    procedure SetPerformance(const Value: TTePerformance);
  protected
    FWidth, FHeight: integer;
    { VCL }
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Paint; override;
    { Painting }
    procedure PaintBorder; virtual;
    procedure PaintBuffer; virtual;
    function GetBorderRect: TRect; virtual;
    { ScrollBars }
    procedure InitScrollBars;
    function CreateScrollBar: TControl; virtual;
    function GetScrollBarHeight: integer; virtual;
    procedure UpdateScrollBars;
    procedure DoHScroll(Sender: TObject; ScrollCode: TTeScrollCode; var ScrollPos: Integer);
    procedure DoVScroll(Sender: TObject; ScrollCode: TTeScrollCode; var ScrollPos: Integer);
    { Event }
    procedure MouseEnter; dynamic;
    procedure MouseLeave; dynamic;
    procedure HasFocus; dynamic;
    procedure KillFocus; dynamic;
    { Protected }
    procedure PaintOwnerBackground(DC: HDC);
    procedure BorderChanged; virtual;
    { Protected Propperty }
    property ControlFont: TFont read FFont write SetFont;
    property DrawXPBorder: boolean read FDrawXPBorder write FDrawXPBorder;
    { Bevel styles }
    property BevelSides: TTeBevelSides read FBevelSides write SetBevelSides;
    property BevelInner: TTeBevelCut read FBevelInner write SetBevelInner;
    property BevelOuter: TTeBevelCut read FBevelOuter write SetBevelOuter;
    property BevelKind: TTeBevelKind read FBevelKind write SetBevelKind;
    property BevelWidth: integer read FBevelWidth write SetBevelWidth;
    property BorderWidth: integer read FBorderWidth write SetBorderWidth;
    property Focused: boolean read FFocused;
    property MouseInControl: boolean read FMouseInControl write FMouseInControl;
    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;
    property HScrollBar: TControl read FHScrollBar;
    property VScrollBar: TControl read FVScrollBar;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

    procedure InvalidateBorder;
    procedure InvalidateRect(ARect: TRect);

    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    function GetClientRect: TRect; override;

    function GetScrollPos(ScrollBar: integer): integer;
    function GetScrollInfo(ScrollBar: integer; var AInfo: TScrollInfo): boolean;
    procedure GetScrollRange(ScrollBar: integer; var Min, Max: integer);
    procedure SetScrollInfo(ScrollBar: integer; AInfo: TScrollInfo; Redraw: boolean);
    procedure SetScrollPos(ScrollBar, Pos: integer; Redraw: boolean);
    procedure SetScrollRange(ScrollBar, Min, Max: integer; Redraw: boolean);
  published
    property Constraints;
    property BiDiMode;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Performance: TTePerformance read FPerformance write SetPerformance;
    property ParentBiDiMode;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  end;

{ TTeControl class }

  TTeGraphicControl = class(TGraphicControl)
  private
    FFocused: boolean;
    FMouseInControl: Boolean;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FFont: TFont;
    FPerformance: TTePerformance;
    procedure SetFont(const Value: TFont);
    procedure SetPerformance(const Value: TTePerformance);
  protected
    { Windows }
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    { For next }
    procedure PaintOwnerBackground(DC: HDC);
    procedure PaintBuffer; virtual;
    { Event }
    procedure MouseEnter; dynamic;
    procedure MouseLeave; dynamic;
    { Protected Propperty }
    property ControlFont: TFont read FFont write SetFont;
    property MouseInControl: boolean read FMouseInControl write FMouseInControl;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Paint; override;
  published
    property BiDiMode;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Performance: TTePerformance read FPerformance write SetPerformance;
    property ParentBiDiMode;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
  end;

const

{ Bevel styles and colors }

  OuterBevelKind: array [TTeBevelKind] of TTeBevelCut =
    (kbvNone, kbvLowered, kbvLowered, kbvLowered, kbvBorder, kbvFlatBorder);
  InnerBevelKind: array [TTeBevelKind] of TTeBevelCut =
    (kbvNone, kbvLowered, kbvLowered, kbvLowered, kbvBorder, kbvFlatBorder);

  OuterBevelRaisedColor: array [TTeBevelCut] of TColor =
    (clNone, clBtnShadow, clBtnHighlight, clBtnFace, cl3DDkShadow, clBtnShadow);
  OuterBevelSunkenColor: array [TTeBevelCut] of TColor =
    (clNone, clBtnHighlight, cl3DDkShadow, clBtnFace, cl3DDkShadow, clBtnShadow);

  InnerBevelRaisedColor: array [TTeBevelCut] of TColor =
    (clNone, cl3DDkShadow, clBtnShadow, clBtnFace, clWindow, clBtnFace);
  InnerBevelSunkenColor: array [TTeBevelCut] of TColor =
    (clNone, clBtnFace, clBtnShadow, clBtnFace, clWindow, clBtnFace);

{ Shared Buffer }

  SharedBuffer: TTeBitmap    = nil; { Shared buffer }

procedure InitSharedBuffer;


const
  ItemStep              = 20;
  GlyphWidth            = 22;
  SubMenuWidth          = 22;
  SepHeight             = 15;

  ScrollButtonSize      = 10;
  ScrollTimerInterval   = 100;

  WM_CLICKEVENT = WM_USER + 1210; { Need for handle OnClick event }

type

  TTeMenuScrollButton = (ksbNone, ksbUp, ksbDown);

  TTeItem = class;

  TTeItemActionLink = class(TActionLink)
  protected
    FClient: TTeItem;
    procedure AssignClient (AClient: TObject); override;
    function IsCaptionLinked: Boolean; override;
    function IsCheckedLinked: Boolean; override;
    function IsEnabledLinked: Boolean; override;
    function IsHelpContextLinked: Boolean; override;
    function IsHintLinked: Boolean; override;
    function IsImageIndexLinked: Boolean; override;
    function IsShortCutLinked: Boolean; override;
    function IsVisibleLinked: Boolean; override;
    function IsOnExecuteLinked: Boolean; override;
    procedure SetCaption (const Value: String); override;
    procedure SetChecked (Value: Boolean); override;
    procedure SetEnabled (Value: Boolean); override;
    procedure SetHelpContext (Value: THelpContext); override;
    procedure SetHint (const Value: String); override;
    procedure SetImageIndex (Value: Integer); override;
    procedure SetShortCut (Value: TShortCut); override;
    procedure SetVisible (Value: Boolean); override;
    procedure SetOnExecute (Value: TNotifyEvent); override;
  end;

  TTeItemActionLinkClass = class of TTeItemActionLink;

  TTeItemView = class;

  TTeMDIItemKind = (mikNone, mikClose, mikRestore, mikMinimize, mikSysMenu);

  {$IFNDEF KS_COMPILER5_UP}
  TImageIndex = type Integer;
  {$ENDIF}

{ TTeItem }

  TTeItem = class(TComponent)
  private
    FCaption: WideString;
    FChecked: Boolean;
    FEnabled: Boolean;
    FHelpContext: THelpContext;
    FHint: String;
    FImageIndex: TImageIndex;
    FImages: TCustomImageList;
    FShortCut: TShortCut;
    FVisible: Boolean;
    FThemeObject: TTeThemeObject;
    FOnClick: TNotifyEvent;
    FOnBeforeDropDown: TNotifyEvent;

    FActionLink: TTeItemActionLink;
    FParent: TTeItem;
    FParentComponent: TComponent;
    FItems: TList;
    FOnInternalChange: TNotifyEvent;
    FMDIItemKind: TTeMDIItemKind;
    FActiveMDIForm: TComponent;
    FFirst: boolean;
    FOnlyFirst: boolean;
    FOwnerForm: TWinControl;
    FBiDiMode: TBiDiMode;
    FIsToolbar: boolean;
    FTray: boolean;
    FScrolled: boolean;
    FTopItem: integer;
    FScrollCount: integer;
    FDrawingDisabled: boolean;
    FItemRect: TRect;
    FPopupMenuOptions: TTePopupMenuOptions;
    function GetAction: TBasicAction;
    procedure SetAction (Value: TBasicAction);
    procedure SetCaption (Value: WideString);
    procedure SetChecked (Value: Boolean);
    procedure SetEnabled (Value: Boolean);
    procedure SetImageIndex (Value: TImageIndex);
    procedure SetImages (Value: TCustomImageList);
    procedure SetVisible (Value: Boolean);
    function GetItemCount: integer;
    function GetItem(Index: Integer): TTeItem;
    function GetOwnerCustomForm: TComponent;

    procedure DoActionChange(Sender: TObject);
    function IsCaptionStored: Boolean;
    function IsCheckedStored: Boolean;
    function IsEnabledStored: Boolean;
    function IsHelpContextStored: Boolean;
    function IsHintStored: Boolean;
    function IsImageIndexStored: Boolean;
    function IsOnClickStored: Boolean;
    function IsShortCutStored: Boolean;
    function IsVisibleStored: Boolean;

    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean);
    function GetImgList: TCustomImageList;
    procedure SetActiveMDIForm(const Value: TComponent);
    procedure SetFirst(const Value: boolean);
    procedure SetOnlyFirst(const Value: boolean);
    procedure SetOwnerForm(const Value: TWinControl);
    function UseRightToLeftAlignment: Boolean;
    function UseRightToLeftReading: Boolean;
    procedure SetBiDiMode(const Value: TBiDiMode);
    procedure SetIsToolbar(const Value: boolean);
    procedure SetTray(const Value: boolean);
    procedure SetScrollCount(const Value: integer);
    procedure SetScrolled(const Value: boolean);
    procedure SetTopItem(const Value: integer);
    procedure SetDrawingDisabled(const Value: boolean);
    procedure SetPopupMenuOptions(const Value: TTePopupMenuOptions);
    function GetMenuIndex: integer;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetParentComponent(Value: TComponent); override;

    function DrawTextBiDiModeFlags(Flags: Integer): Longint;
    function DrawTextBiDiModeFlagsReadingOnly: Longint;