terollform.pas

这个东西的功能很强大

    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;

    procedure DoClick; dynamic;

    function CreatePopupWindowClass: TClass; virtual;
    property ActionLink: TTeItemActionLink read FActionLink write FActionLink;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

    function HasParent: Boolean; override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetParentComponent: TComponent; override;

    function FindItem(Value: Integer; Kind: TFindItemKind): TTeItem;
    function FindItemByChar(C: Char): TTeItem;
    function IsShortCut(var Msg: TWMKey): boolean;

    procedure Click; dynamic;
    procedure Change; virtual;

    procedure Popup(View: TTeItemView; X, Y: integer; Rect: TRect);

    function GetGlyphSize: integer;
    procedure CalcSize(Canvas: TCanvas; View: TTeItemView; var AWidth, AHeight: integer); virtual;
    procedure DrawItem(Canvas: TCanvas; View: TTeItemView; Rect: TRect; Active, Hover: boolean); virtual;
    procedure DrawScrollButton(Canvas: TCanvas; View: TTeItemView; Rect: TRect; Button: TTeMenuScrollButton; Active: boolean); virtual;

    procedure Clear;
    procedure Add(AItem: TTeItem);
    function ContainsItem(AItem: TTeItem): Boolean;
    procedure Delete(Index: Integer);
    function IndexOf(AItem: TComponent): Integer;
    procedure Insert(NewIndex: Integer; AItem: TTeItem);
    procedure Remove(Item: TTeItem);
    procedure InitiateAction; virtual;
    { MenuBar Animation }
    property First: boolean read FFirst write SetFirst;
    property OnlyFirst: boolean read FOnlyFirst write SetOnlyFirst;
    { PopupMenuOptions options }
    property PopupMenuOptions: TTePopupMenuOptions read FPopupMenuOptions write SetPopupMenuOptions;
    { Intenal properies }
    property ActiveMDIForm: TComponent read FActiveMDIForm write SetActiveMDIForm;
    property DrawingDisabled: boolean read FDrawingDisabled write SetDrawingDisabled;
    property ItemRect: TRect read FItemRect write FItemRect;
    property IsToolbar: boolean read FIsToolbar write SetIsToolbar;
    property MDIItemKind: TTeMDIItemKind read FMDIItemKind write FMDIItemKind;
    property OwnerForm: TWinControl read FOwnerForm write SetOwnerForm;
    property Tray: boolean read FTray write SetTray;
    { Properties }
    property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode;
    property ImgList: TCustomImageList read GetImgList;
    property Items[Index: Integer]: TTeItem read GetItem; default;
    { Scroll}
    property TopItem: integer read FTopItem write SetTopItem;

    property OnInternalChange: TNotifyEvent read FOnInternalChange write FOnInternalChange stored false;
  published
    { Properties }
    property Action: TBasicAction read GetAction write SetAction;
    property Count: Integer read GetItemCount;
    property HelpContext: THelpContext read FHelpContext write FHelpContext stored IsHelpContextStored default 0;
    property Hint: String read FHint write FHint stored IsHintStored;
    property Parent: TTeItem read FParent;
    property ParentComponent: TComponent read FParentComponent write FParentComponent;
    property Checked: Boolean read FChecked write SetChecked stored IsCheckedStored default False;
    property Enabled: Boolean read FEnabled write SetEnabled stored IsEnabledStored default True;
    property Caption: WideString read FCaption write SetCaption stored IsCaptionStored;
    property MenuIndex: integer read GetMenuIndex;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;
    property Images: TCustomImageList read FImages write SetImages;
    property Scrolled: boolean read FScrolled write SetScrolled;
    property ScrollCount: integer read FScrollCount write SetScrollCount;
    property ShortCut: TShortCut read FShortCut write FShortCut stored IsShortCutStored default 0;
    property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True;
    property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored;
    property OnBeforeDropDown: TNotifyEvent read FOnBeforeDropDown write FOnBeforeDropDown;
  end;

  TTeItemClass = class of TTeItem;

{ TTeItemView class }

  TTeViewOrientation = (voVertical, voHorizontal);

  TTeItemView = class(TComponent)
  private
    FItems: TTeItem;
    FIsMenuBar: boolean;
    FOrientation: TTeViewOrientation;
    FParentComponent: TComponent;
    FWindow: TWinControl;
    FSelItem: TTeItem;
    FDropDown: boolean;
    FLoop: boolean;

    FParentView: TTeItemView;
    FChildView: TTeItemView;

    FCanvas: TCanvas;
    FLeft: integer;
    FTop: integer;
    FWidth, FHeight: integer;
    FScrollTimer: TTimer;
    FPopupTimer: TTimer;
    FActiveScrollButton: TTeMenuScrollButton;
    procedure DoScrollTimer(Sender: TObject);
  protected
    procedure SetSize(ASize: TPoint); virtual;
    procedure SetPosition(APosition: TPoint); virtual;
    function CheckDropDown: Boolean;

    procedure InvalidateView; virtual;
    procedure InvalidateItem(AItem: TTeItem); virtual;
    procedure InvalidateScrollButton(Button: TTeMenuScrollButton); virtual;

    function Popup: Boolean;
    procedure SelectNext;
    procedure SelectPrev;

    procedure StartScroll;
    procedure StopScroll;

    property Loop: boolean read FLoop;
    property SelItem: TTeItem read FSelItem;
    property ActiveScrollButton: TTeMenuScrollButton read FActiveScrollButton;
  public
    constructor CreateView(AOwner: TComponent; AIsMenuBar: boolean;
      AOrientation: TTeViewOrientation);
    destructor Destroy; override;

    procedure InitiateAction; virtual;

    procedure CalcSize;
    function MessageLoop: Boolean;

    procedure Paint(Canvas: TCanvas); virtual;
    { Mouse routines }
    function GetItemRect(Item: TTeItem): TRect;
    function GetScrollButtonRect(Button: TTeMenuScrollButton): TRect;
    procedure UpdateHover(P: TPoint);
    { Properties }
    property Canvas: TCanvas read FCanvas write FCanvas;
    property Items: TTeItem read FItems write FItems;
    property IsMenuBar: boolean read FIsMenuBar;
    property ParentComponent: TComponent read FParentComponent write FParentComponent;
    property ParentView: TTeItemView read FParentView write FParentView;
    property Window: TWinControl read FWindow write FWindow;
    property Left: integer read FLeft write FLeft;
    property Top: integer read FTop write FTop;
    property Width: integer read FWidth;
    property Height: integer read FHeight;
  end;

  EKsItemError = class(Exception);

{ TTeItemContainer abstract items container }

  TTeInsertItemProc = procedure(AParent: TComponent; AItem: TTeItem) of object;
  TTeGetItemClassProc = procedure(var AItemClass: TTeItemClass) of object;

procedure RegisterContainerClass(const AClass: TClass; AInsertItemProc: TTeInsertItemProc;
  AGetItemClassProc: TTeGetItemClassProc);
procedure UnregisterContainerClass(const AClass: TClass);
function GetItemClass(const AClass: TClass): TTeItemClass;

var
  MenuFont: TFont;


type

{ TTePopupMenu class }

{ TTePopupMenu encapsulates the properties, methods, and events of a advanced pop-up menu. }
  TTePopupMenu = class(TPopupMenu)
  private
    FItems: TTeItem;
    FPopupMenuOptions: TTePopupMenuOptions;
    { proeprty }
    function GetImages: TCustomImageList;
    procedure SetImages(Value: TCustomImageList);
    procedure SetPopupMenuOptions(const Value: TTePopupMenuOptions);
  protected
    { need for }
    class procedure InsertItemProc(AParent: TComponent; AItem: TTeItem); virtual;
    class procedure GetItemClassProc(var AItemClass: TTeItemClass); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;

    procedure Popup(X, Y: integer); override;
    procedure Close; virtual;
  published
    property Images: TCustomImageList read GetImages write SetImages;
    property Items: TTeItem read FItems;
    property PopupMenuOptions: TTePopupMenuOptions read FPopupMenuOptions write SetPopupMenuOptions;
    property OnPopup;
  end;


  TTeDefaultMenuOptions = record
    Enabled: Boolean;
    Blending: TTeBlending;
    Shadow: TTeShadow;
    Animation: TTeAnimation;
  end;

var
  DefaultMenuOptions: TTeDefaultMenuOptions;




type

  TTeScrollBarInc = 1..32767;

  TTeScrollBar = class(TTeGraphicControl)
  private
    FLastMouseX, FLastMouseY: integer;
    FRepeatTimer: TTimer;

    FSliderCatchCoord: integer;

    FMouseOnSlider: boolean;
    FMouseOnLeftTopBtn: boolean;
    FMouseOnRightBottomBtn: boolean;
    FMouseOnLeftTopTrack: boolean;
    FMouseOnRightBottomTrack: boolean;

    FMDownOnLeftTopBtn: boolean;
    FMDownOnRightBottomBtn: boolean;
    FMDownOnLeftTopTrack: boolean;
    FMDownOnRightBottomTrack: boolean;

    FPosition: integer;
    FMin: integer;
    FBorderWidth: integer;
    FMax: integer;
    FPageSize: integer;
    FOrientation: TTeScrollOrientation;
    FShowButtons: boolean;
    FLargeChange: TScrollBarInc;
    FSmallChange: TScrollBarInc;
    FOnChange: TNotifyEvent;
    FOnScroll: TTeScrollEvent;
    FAutoScrollUp: boolean;
    FAutoScrollDown: boolean;
    FThemeObject: TTeThemeObject;
    function CalculateSliderSize: integer;
    procedure SetBorderWidth(const Value: integer);
    procedure SetMax(const Value: integer);
    procedure SetMin(const Value: integer);
    procedure SetPageSize(const Value: integer);
    procedure SetPosition(const Value: integer);
    procedure SetOrientation(const Value: TTeScrollOrientation);
    procedure SetShowButtons(const Value: boolean);

    function GetSliderPressed: boolean;
    function GetLeftTopBtnPressed: boolean;
    function GetRightBottomBtnPressed: boolean;
    function GetLeftTopTrackPressed: boolean;
    function GetRightBottomTrackPressed: boolean;

    procedure PartPress(FirstTime: boolean);

    procedure TimerExpired(Sender: TObject);

    procedure SetAutoSrcollUp(const Value: boolean);
    procedure SetAutoSrcollDown(const Value: boolean);
    procedure SetThemeObject(const Value: TTeThemeObject);
  protected
    procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;

    procedure Change; dynamic;
    procedure Scroll(ScrollCode: TTeScrollCode; var ScrollPos: Integer); dynamic;
    function PositionCoordinate(APos: integer): word;
    function CoordinatePosition(ACoord: word): integer;

    procedure PaintBuffer; override;

    procedure DrawLeftTopBtn; virtual;
    procedure DrawRightBottomBtn; virtual;
    procedure DrawTrack; virtual;
    procedure DrawSlider; virtual;
    procedure DrawBackground; virtual;
    procedure DrawBorder; virtual;

    function IsSliderVizible: boolean;
    function GetBtnSize: integer; virtual;
    function GetSliderSize: integer; virtual;
    function GetLeftTopBtnRect: TRect; virtual;
    function GetRightBottomBtnRect: TRect; virtual;
    function GetSliderRect: TRect; virtual;
    function GetBackgroundRect: TRect; virtual;
    function GetLeftTopTrackRect: TRect; virtual;
    function GetRightBottomTrackRect: TRect; virtual;
    function PtInLeftTopBtn(x, y: integer): boolean; virtual;
    function PtInRightBottomBtn(x, y: integer): boolean; virtual;
    function PtInSlider(x, y: integer): boolean; virtual;
    function PtInLeftTopTrack(x, y: integer): boolean; virtual;
    function PtInRightBottomTrack(x, y: integer): boolean; virtual;
    { Events }
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; x, y: integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: integer); override;
    procedure MouseMove(Shift: TShiftState; x, y: integer); override;
    procedure ImitateKeyDown(var Key: word; Shift: TShiftState);
    { Internal Properties }
    property MouseOnSlider: boolean read FMouseOnSlider;
    property SliderPressed: boolean read GetSliderPressed;
    property MouseOnLeftTopBtn: boolean read FMouseOnLeftTopBtn;
    property LeftTopBtnPressed: boolean read GetLeftTopBtnPressed;
    property MouseOnRightBottomBtn: boolean read FMouseOnRightBottomBtn;
    property RightBottomBtnPressed: boolean read GetRightBottomBtnPressed;
    property MouseOnLeftTopTrack: boolean read FMouseOnLeftTopTrack;
    property LeftTopTrackPressed: boolean read GetLeftTopTrackPressed;
    property MouseOnRightBottomTrack: boolean read FMouseOnRightBottomTrack;
    property RightBottomTrackPressed: boolean read GetRightBottomTrackPressed;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure UpdateSytemSize;

    property AutoScrollUp : boolean read FAutoScrollUp write SetAutoSrcollUp;
    property AutoScrollDown : boolean read FAutoScrollDown write SetAutoSrcollDown;
  published
    { Properties }
    property Align;
    property Anchors;
    property BiDiMode;
    { Specifies the distance, in pixels, between the border and bar area. }
    property BorderWidth: integer read FBorderWidth write SetBorderWidth default 1;
    property ShowButtons: boolean read FShowButtons write SetShowButtons default true;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Orientation: TTeScrollOrientation read FOrientation write SetOrientation default ksoHorizontal;
    property LargeChange: TScrollBarInc read FLargeChange write FLargeChange default 1;
    property Max: integer read FMax write SetMax default 100;
    property Min: integer read FMin write SetMin default 0;
    property PageSize: integer read FPageSize write SetPageSize default 0;
    property ParentBiDiMode;
    property ParentShowHint;
    property Performance;
    property PopupMenu;