xppages.pas

非常好的xp界面控件

unit xpPages;

interface

{$I xpDelphi.inc}

uses xpReg,
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, xpGraphUtil;



const
  TCS_SCROLLOPPOSITE    = $0001;  // assumes multiline tab
  TCS_BOTTOM            = $0002;
  TCS_RIGHT             = $0002;
  TCS_MULTISELECT       = $0004;  // allow multi-select in button mode
  TCS_FLATBUTTONS       = $0008;
  TCS_FORCEICONLEFT     = $0010;
  TCS_FORCELABELLEFT    = $0020;
  TCS_HOTTRACK          = $0040;
  TCS_VERTICAL          = $0080;
  TCS_TABS              = $0000;
  TCS_BUTTONS           = $0100;
  TCS_SINGLELINE        = $0000;
  TCS_MULTILINE         = $0200;
  TCS_RIGHTJUSTIFY      = $0000;
  TCS_FIXEDWIDTH        = $0400;
  TCS_RAGGEDRIGHT       = $0800;
  TCS_FOCUSONBUTTONDOWN = $1000;
  TCS_OWNERDRAWFIXED    = $2000;
  TCS_TOOLTIPS          = $4000;
  TCS_FOCUSNEVER        = $8000;

  TCS_EX_FLATSEPARATORS = $00000001;
  TCS_EX_REGISTERDROP   = $00000002;


  TCM_FIRST               = $1300;      { Tab control messages }

  TCM_GETIMAGELIST       = TCM_FIRST + 2;
  TCM_SETIMAGELIST       = TCM_FIRST + 3;
  TCM_GETITEMCOUNT       = TCM_FIRST + 4;
  TCM_DELETEITEM         = TCM_FIRST + 8;
  TCM_DELETEALLITEMS     = TCM_FIRST + 9;
  TCM_GETITEMRECT        = TCM_FIRST + 10;
  TCM_GETCURSEL          = TCM_FIRST + 11;
  TCM_SETCURSEL          = TCM_FIRST + 12;
  TCM_HITTEST            = TCM_FIRST + 13;
  TCM_SETITEMEXTRA       = TCM_FIRST + 14;
  TCM_ADJUSTRECT         = TCM_FIRST + 40;
  TCM_SETITEMSIZE        = TCM_FIRST + 41;
  TCM_REMOVEIMAGE        = TCM_FIRST + 42;
  TCM_SETPADDING         = TCM_FIRST + 43;
  TCM_GETROWCOUNT        = TCM_FIRST + 44;
  TCM_GETTOOLTIPS        = TCM_FIRST + 45;
  TCM_SETTOOLTIPS        = TCM_FIRST + 46;
  TCM_GETCURFOCUS        = TCM_FIRST + 47;
  TCM_SETCURFOCUS        = TCM_FIRST + 48;
  TCM_SETMINTABWIDTH     = TCM_FIRST + 49;
  TCM_DESELECTALL        = TCM_FIRST + 50;
  TCM_HIGHLIGHTITEM      = TCM_FIRST + 51;
  TCM_SETEXTENDEDSTYLE   = TCM_FIRST + 52;  // optional wParam == mask
  TCM_GETEXTENDEDSTYLE   = TCM_FIRST + 53;

  TCIF_TEXT       = $0001;
  TCIF_IMAGE      = $0002;
  TCIF_RTLREADING = $0004;
  TCIF_PARAM      = $0008;
  TCIF_STATE      = $0010;

  TCIS_BUTTONPRESSED      = $0001;
  TCIS_HIGHLIGHTED        = $0002;

  TCM_GETITEMA             = TCM_FIRST + 5;
  TCM_SETITEMA             = TCM_FIRST + 6;
  TCM_INSERTITEMA          = TCM_FIRST + 7;
  TCM_GETITEMW             = TCM_FIRST + 60;
  TCM_SETITEMW             = TCM_FIRST + 61;
  TCM_INSERTITEMW          = TCM_FIRST + 62;

  TCM_GETITEM             = TCM_GETITEMA;
  TCM_SETITEM             = TCM_SETITEMA;
  TCM_INSERTITEM          = TCM_INSERTITEMA;



// tab styles - search win32 api help for TCS_ for info on each style
type
  TxpTabPosition = (tpTop, tpBottom, tpLeft, tpRight);

  TxpPageControlStyle = (pcsTabs, pcsButtons, pcsFlatButtons, pcsXP);

type
  tagTCITEMA = packed record
    mask: UINT;
    dwState: UINT;
    dwStateMask: UINT;
    pszText: PAnsiChar;
    cchTextMax: Integer;
    iImage: Integer;
    lParam: LPARAM;
  end;

  tagTCITEMW = packed record
    mask: UINT;
    dwState: UINT;
    dwStateMask: UINT;
    pszText: PWideChar;
    cchTextMax: Integer;
    iImage: Integer;
    lParam: LPARAM;
  end;


  TTCItemA = tagTCITEMA;
  TTCItemW = tagTCITEMW;
  TTCItem = TTCItemA;

const
  TCHT_NOWHERE     = $0001;
  TCHT_ONITEMICON  = $0002;
  TCHT_ONITEMLABEL = $0004;
  TCHT_ONITEM      = TCHT_ONITEMICON or TCHT_ONITEMLABEL;

type
  PTCHitTestInfo = ^TTCHitTestInfo;
  tagTCHITTESTINFO = packed record
    pt: TPoint;
    flags: UINT;
  end;

  _TC_HITTESTINFO = tagTCHITTESTINFO;
  TTCHitTestInfo = tagTCHITTESTINFO;
  TC_HITTESTINFO = tagTCHITTESTINFO;

  tagTCKEYDOWN = packed record
    hdr: TNMHDR;
    wVKey: Word;
    flags: UINT;
  end;
  _TC_KEYDOWN = tagTCKEYDOWN;
  TTCKeyDown = tagTCKEYDOWN;
  TC_KEYDOWN = tagTCKEYDOWN;


// event to allow different mapping of glyphs from the imagelist component
type
  TGlyphMapEvent = procedure(Control: TWinControl; PageIndex : integer; var GlyphIndex : integer) of object;

  TOwnerDrawState = set of (odSelected, odGrayed, odDisabled, odChecked,
    odFocused, odDefault, odHotLight, odInactive, odNoAccel, odNoFocusRect,
    odReserved1, odReserved2, odComboBoxEdit);

  TDrawItemEvent = procedure(Control: TWinControl; Index: Integer; ACanvas : TControlCanvas;
    ARect: TRect; State: TOwnerDrawState) of object;


type
  TxpPageControl = class (TPageControl)
  private
    FCanvas : TControlCanvas;      // canvas for drawing on with tabOwnerDraw
    FImageList : TImageList;          // link to a TImageList component
    FOnDrawItem : TDrawItemEvent;  // Owner draw event
    FOnGlyphMap : TGlyphMapEvent;  // glyph mapping event

    FBorderColor : TColor;
    FHotTrackTab : Integer;
    FBorderRect  : TRect;
    FTabPosition : TxpTabPosition;


    FOwnerDraw : Boolean;
    FStyle : TxpPageControlStyle;

    FTabTextAlignment : TAlignment;

    function  PageIndexToWin (AIndex : Integer) : Integer;
    function  WinIndexToPage (AIndex : Integer) : Integer;
    procedure SetGlyphs (Value : TImageList);
    function  GetMultiline : boolean;
    procedure CNDrawItem (var Msg : TWMDrawItem); message CN_DRAWITEM;
    procedure WMAdjasment (var Msg : TMessage); message TCM_ADJUSTRECT;
    procedure WMNCPaint (var Message : TWMNCPaint); message WM_NCPAINT;
    procedure WMNCCalcSize (var Message : TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMPaint (var Message : TWMPaint); message WM_PAINT;
    procedure WMMouseMove (var Message : TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMSIZE (var Message : TWMSIZE); message WM_SIZE;
    procedure MouseLeave (var Message : TMessage); message CM_MOUSELEAVE;
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
    procedure WMSysColorChange (var Message: TMessage); message WM_SYSCOLORCHANGE;
    procedure GlyphsChanged (Sender : TObject);

    procedure SetTabPosition (Value : TxpTabPosition);
    procedure SetTabTextAlignment (Value : TAlignment);

    procedure SetBorderColor (Value : TColor);
    procedure SetStyle (Value : TxpPageControlStyle);
    procedure SetOwnerDraw (AValue : Boolean);
  protected
    procedure CreateParams (var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); virtual;
    procedure DrawItemInside (AIndex : Integer; ACanvas : TCanvas; ARect : TRect); virtual;
    procedure DrawBorder (ACanvas : TCanvas); virtual;

    procedure DrawTopTab (TabRect : TRect; ACanvas : TCanvas; AIndex, AVisibleIndex : Integer);
    procedure DrawBottomTab (TabRect : TRect; ACanvas : TCanvas; AIndex, AVisibleIndex : Integer);
    procedure DrawLeftTab (TabRect : TRect; ACanvas : TCanvas; AIndex, AVisibleIndex : Integer);
    procedure DrawRightTab (TabRect : TRect; ACanvas : TCanvas; AIndex, AVisibleIndex : Integer);



    procedure DrawHotTrackTab (ATabIndex : Integer; AHotTrack : Boolean);
    procedure Loaded; override;
    // for owner draw
    property Canvas : TControlCanvas read FCanvas write FCanvas;
    // republish Multiline as read only
    property MultiLine : boolean read GetMultiline;

  public
    procedure UpdateGlyphs; virtual;
  published
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    // link to TImageList
    property ImageList : TImageList Read FImageList write SetGlyphs;
    // owner draw event
    property OnDrawItem : TDrawItemEvent read FOnDrawItem write FOnDrawItem;
    // glyph map event
    property OnGlyphMap : TGlyphMapEvent read FOnGlyphMap write FOnGlyphMap;

    property OwnerDraw : Boolean read FOwnerDraw write SetOwnerDraw default False;
    property BorderColor : TColor read FBorderColor write SetBorderColor;
    property TabPosition : TxpTabPosition read FTabPosition write SetTabPosition;
    property TabTextAlignment : TAlignment read FTabTextAlignment write SetTabTextAlignment;
    property Style : TxpPageControlStyle read FStyle write SetStyle;
  end;

// redeclare TTabSheet so it can have a component editor declared here


type
  TxpTabBGStyle = (bgsNone, bgsGradient, bgsTileImage, bgsStrechImage);

type
  TxpTabSheet = class (TTabSheet)
  private
    FCanvas : TControlCanvas;
    FColor : TColor;
    FGradientStartColor : TColor;
    FGradientEndColor : TColor;
    FGradientFillDir : TFillDirection;
    FImageIndex : Integer;
    FShowTabHint : Boolean;
    FTabHint : String;
    FBGImage : TBitmap;
    FBGStyle : TxpTabBGStyle;

    procedure SetColor (AValue : TColor);
    procedure WMNCPaint (var Message : TWMNCPaint); message WM_NCPAINT;
    procedure WMPaint (var Message : TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure SetImageIndex (AIndex : Integer);

    procedure SetBGImage (AValue : TBitmap);
    procedure SetBGStyle (AValue : TxpTabBGStyle);
    procedure SetGradientStartColor (AValue : TColor);
    procedure SetGradientEndColor (AValue : TColor);
    procedure SetGradientFillDir (AValue : TFillDirection);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy;
  published
    property Color : TColor read FColor write SetColor;
    property ImageIndex : Integer read FImageIndex write SetImageIndex default -1;
    property ShowTabHint : Boolean read FShowTabHint write FShowTabHint default False;
    property TabHint : String read FTabHint write FTabHint;
    property BGImage : TBitmap read FBGImage write SetBGImage;
    property BGStyle : TxpTabBGStyle read FBGStyle write SetBGStyle;
    property GradientStartColor : TColor read FGradientStartColor write SetGradientStartColor;
    property GradientEndColor : TColor read FGradientEndColor write SetGradientEndColor;
    property GradientFillDir : TFillDirection read FGradientFillDir write SetGradientFillDir;
  end;



implementation

const
  DefaultTabWidth = 100;

// constructor must create a TControlCanvas for the owner draw style

constructor TxpPageControl.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FCanvas := TControlCanvas.Create;

  FBorderColor := clSilver;
  FTabPosition := tpTop;

  FHotTrackTab := -1;

  ShowHint := true;
  FStyle := pcsXP;

  FTabTextAlignment := taCenter;
  FOwnerDraw := False;
end;

// remove link with glyphs and free the canvas

destructor TxpPageControl.Destroy;
begin
  try
    FCanvas.Free;
  except
  end;
  if Assigned (FImageList) then
  try
    FImageList.OnChange := nil;
  except
  end;
  inherited Destroy;
end;

// CreateParams called to set the additional style bits

procedure TxpPageControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams (Params);

  with Params do
  begin
    case FStyle of
      pcsTabs: Style:= Style or TCS_TABS;
      pcsButtons: Style:= Style or TCS_BUTTONS;
      pcsFlatButtons: Style := Style or TCS_BUTTONS or TCS_FLATBUTTONS;
      pcsXP: begin end;
    end;


    if FOwnerDraw then Style := Style or TCS_OWNERDRAWFIXED;

    case FTabPosition of
      tpTop:
      begin
        //Style := Style and (not TCS_VERTICAL) and (not TCS_BOTTOM);
      end;
      tpBottom:
      begin
        Style := Style or TCS_BOTTOM;
      end;
      tpLeft:
      begin
        Style := Style or TCS_VERTICAL;
      end;
      tpRight:
      begin
        Style := Style or TCS_VERTICAL or TCS_RIGHT;
      end;
    end;
  end;
end;

// CreateWnd also must set links to the glyphs

procedure TxpPageControl.CreateWnd;
begin
  inherited CreateWnd;
  if Assigned (FImageList) then SetGlyphs (FImageList);
end;

// if the glyphs should change then update the tabs

procedure TxpPageControl.GlyphsChanged (Sender : TObject);
begin
  if Assigned (FImageList) then UpdateGlyphs;
end;

// multiline property redefined as readonly, this makes it
// disappear from the object inspector

function TxpPageControl.GetMultiline : boolean;
begin
  Result := inherited Multiline
end;

// link the tabs to the glyph list
// nil parameter removes link

procedure TxpPageControl.SetGlyphs (Value : TImageList);
var
  I : Integer;
begin
  FImageList := Value;
  if Assigned(FImageList) then
    begin
      SendMessage (Handle, TCM_SETIMAGELIST, 0, FImageList.Handle);
      For I := 0 to PageCount - 1 do
        (Pages[I] as TxpTabSheet).ImageIndex := I;
      FImageList.OnChange := GlyphsChanged
    end
  else
  begin
    SendMessage (Handle, TCM_SETIMAGELIST, 0, 0);
    For I := 0 to PageCount - 1 do
      (Pages[I] as TxpTabSheet).ImageIndex := -1;
  end;
  UpdateGlyphs;
  SendMessage (Handle, WM_SIZE, 0, 0);
end;


// determine properties whenever the tab styles are changed

procedure TxpPageControl.SetOwnerDraw (AValue : Boolean);
begin
  if FOwnerDraw <> AValue then
  begin
    FOwnerDraw := AValue;
    ReCreateWnd;
    SendMessage (Handle, WM_SIZE, 0, 0);
    if (Self.PageCount > 0) and (ActivePage <> nil) then
      ActivePage.Invalidate;
  end
end;

// update the glyphs linked to the tab

procedure TxpPageControl.UpdateGlyphs;
var
  TCItem : TTCItem;
  Control,
  Loop : integer;
begin
  if FImageList <> nil then
  begin
    for Loop := 0 to pred(PageCount) do
    begin
      TCItem.Mask := TCIF_IMAGE;
      TCItem.iImage := Loop;
      Control := Loop;
      // OnGlyphMap allows the user to reselect the glyph linked to a
      // particular tab
      if Assigned (FOnGlyphMap) then
        FOnGlyphMap (Self, Control, TCItem.iImage);

      if SendMessage (Handle, TCM_SETITEM, Control, longint(@TCItem)) = 0 then;
        //raise EListError.Create ('TxpPageControl error in setting tab glyph')
    end
  end
end;

// called when Owner Draw style is selected:
// retrieve the component style, set up the canvas and