stabcontrol.pas

AlphaControls是一个Delphi标准控件的集合

unit sTabControl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    ImgList, ComCtrls, CommCtrl, sCommonData, sConst;

type

  TsCustomTabControl = class;
  TsDrawTabEvent = procedure (Control: TsCustomTabControl; TabIndex: Integer; const Rect: TRect; Active: Boolean) of object;
  TsTabInfo = record
    Caption : string;
    Index : integer;
    ImageIndex : integer;
    R : TRect;
    Size : TSize;
    Row : integer;
    Processed : boolean;
  end;
  TsTabsArray = array of TsTabInfo;

  TsCustomTabControl = class (TWinControl)
  private
    FCanvas: TCanvas;
    FHotTrack: Boolean;
    FImageChangeLink: TChangeLink;
    FImages: TCustomImageList;
    FMultiLine: Boolean;
    FMultiSelect: Boolean;
    FOwnerDraw: Boolean;
    FRaggedRight: Boolean;
    FSaveTabIndex: Integer;
    FSaveTabs: TStringList;
    FScrollOpposite: Boolean;
    FStyle: TTabStyle;
    FTabPosition: TTabPosition;
    FTabs: TStrings;
    FTabSize: TSmallPoint;
    FOnChange: TNotifyEvent;
    FOnChanging: TTabChangingEvent;
    FOnDrawTab: TsDrawTabEvent;
    FOnGetImageIndex: TTabGetImageEvent;
    function GetDisplayRect: TRect;
    function GetTabIndex: Integer;
    procedure ImageListChange(Sender: TObject);
    function InternalSetMultiLine(Value: Boolean): Boolean;
    procedure SetHotTrack(Value: Boolean);
    procedure SetImages(Value: TCustomImageList);
    procedure SetMultiLine(Value: Boolean);
    procedure SetMultiSelect(Value: Boolean);
    procedure SetOwnerDraw(Value: Boolean);
    procedure SetRaggedRight(Value: Boolean);
    procedure SetScrollOpposite(Value: Boolean);
    procedure SetStyle(Value: TTabStyle);
    procedure SetTabHeight(Value: Smallint);
    procedure SetTabPosition(Value: TTabPosition);
    procedure SetTabs(Value: TStrings);
    procedure SetTabWidth(Value: Smallint);
    procedure UpdateTabSize;
    procedure CMFontChanged(var Message); message CM_FONTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMTabStopChanged(var Message: TMessage); message CM_TABSTOPCHANGED;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure WMNotifyFormat(var Message: TMessage); message WM_NOTIFYFORMAT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkGND (var Message: TWMPaint); message WM_ERASEBKGND;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
  protected
    FUpdating: Boolean;
    FCommonData: TsCommonData;
    ChangedSkinSection : string;
    FSavedTabIndex : integer;
    TabsArray : TsTabsArray;
    DrawingLock : boolean;
    Sizing : boolean;
    DrawShadows : boolean;

    procedure SetTabIndex(Value: Integer); virtual;
    procedure AdjustClientRect(var Rect: TRect); override;
    function CanChange: Boolean; dynamic;
    function CanShowTab(TabIndex: Integer): Boolean; virtual;
    procedure Change; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); virtual;
    function GetImageIndex(TabIndex: Integer): Integer; virtual;
    procedure Loaded; override;
    procedure UpdateTabImages;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure TabsChanged;

    property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
    property Images: TCustomImageList read FImages write SetImages;
    property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
    property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
    property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;
    property RaggedRight: Boolean read FRaggedRight write SetRaggedRight default False;
    property ScrollOpposite: Boolean read FScrollOpposite write SetScrollOpposite default False;
    property Style: TTabStyle read FStyle write SetStyle default tsTabs;
    property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;
    property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpTop;
    property Tabs: TStrings read FTabs write SetTabs;
    property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;
    property TabStop default True;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;
    property OnDrawTab: TsDrawTabEvent read FOnDrawTab write FOnDrawTab;
    property OnGetImageIndex: TTabGetImageEvent read FOnGetImageIndex write FOnGetImageIndex;
    procedure WndProc (var Message: TMessage); override;

    procedure WMPaint (var Message: TWMPaint); message WM_PAINT;
    procedure DrawSkinTab(Index: Integer; State : integer); virtual;
    procedure DrawSkinTabs(CI : TCacheInfo); virtual;

    function TabsRect: TRect;
    function GlyphRect: TRect;

    procedure FillTabs;
    procedure UpdateTabRects;

    function IndexOfSkinTab(X, Y : integer) : integer;
    function ActiveTabIndex : integer;

    function ActualIndex(Index : integer) : integer;
    function SkinTabRect(Index : integer) : TRect;
  public
    function PageRect: TRect;

    function FindNextTab(CurTab: integer; GoForward: Boolean): integer;

    function TabRect(Index: Integer): TRect;
    procedure AfterConstruction; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property DisplayRect: TRect read GetDisplayRect;
    function IndexOfTabAt(X, Y: Integer): Integer;
    function GetHitTestInfoAt(X, Y: Integer): THitTests;
    procedure RebuildTabs;
    function RowCount: Integer;
    function OwnCalc : boolean;
    procedure ScrollTabs(Delta: Integer);

    property Canvas: TCanvas read FCanvas;
    property TabIndex: Integer read GetTabIndex write SetTabIndex default -1; // must be after Tabs
  published
    property CommonData : TsCommonData read FCommonData write FCommonData;
  end;

  TsTabControl = class(TsCustomTabControl)
  public
    property DisplayRect;
    property RaggedRight;
    property MultiSelect;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property HotTrack;
    property Images;
    property MultiLine;
    property OwnerDraw;
    property ParentBiDiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ScrollOpposite;
    property ShowHint;
    property Style;
    property TabHeight;
    property TabOrder;
    property TabPosition;
    property Tabs;
    property TabIndex;  // must be after Tabs
    property TabStop;
    property TabWidth;
    property Visible;
    property OnChange;
    property OnChanging;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawTab;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetImageIndex;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

const
  TopOffset = 4;
  BottomOffset = 1;
  LeftOffset = 1;
  RightOffset = 1;

var
  sFlag : boolean;

implementation

uses ComStrs, Consts, sStyleSimply, sMaskData, sSkinProps, sGraphUtils, sUtils,
  sMessages, math, sPageControl;

procedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean);
var
  Style: Integer;
begin
  if Ctl.HandleAllocated then begin
    Style := GetWindowLong(Ctl.Handle, GWL_STYLE);
    if not UseStyle
      then Style := Style and not Value
      else Style := Style or Value;
    SetWindowLong(Ctl.Handle, GWL_STYLE, Style);
  end;
end;

{ TsTabStrings }

type
  TsTabStrings = class(TStrings)
  private
    FTabControl: TsCustomTabControl;
  protected
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
  end;

procedure TabControlError(const S: string);
begin
  raise EListError.Create(S);
end;

procedure TsTabStrings.Clear;
begin
  if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then TabControlError(sTabFailClear);
  if FTabControl.OwnCalc then FTabControl.DrawingLock := True;
  FTabControl.TabsChanged;
  if FTabControl.OwnCalc then FTabControl.DrawingLock := False;
end;

procedure TsTabStrings.Delete(Index: Integer);
begin
  if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then TabControlError(Format(sTabFailDelete, [Index]));
  if FTabControl.OwnCalc then FTabControl.DrawingLock := True;
  FTabControl.TabsChanged;
  if FTabControl.OwnCalc then FTabControl.DrawingLock := False;
end;

function TsTabStrings.Get(Index: Integer): string;
const
  RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
var
  TCItem: TTCItem;
  Buffer: array[0..4095] of Char;
begin
  TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading];
  TCItem.pszText := Buffer;
  TCItem.cchTextMax := SizeOf(Buffer);
  if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, Longint(@TCItem)) = 0 then TabControlError(Format(sTabFailRetrieve, [Index]));
  Result := Buffer;
end;

function TsTabStrings.GetCount: Integer;
begin
  Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);
end;

function TsTabStrings.GetObject(Index: Integer): TObject;
var
  TCItem: TTCItem;
begin
  TCItem.mask := TCIF_PARAM;
  if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, Longint(@TCItem)) = 0 then TabControlError(Format(sTabFailGetObject, [Index]));
  Result := TObject(TCItem.lParam);
end;

procedure TsTabStrings.Put(Index: Integer; const S: string);
const
  RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
var
  TCItem: TTCItem;
begin
  TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE;
  TCItem.pszText := PChar(S);
  TCItem.iImage := FTabControl.GetImageIndex(Index);
  if SendMessage(FTabControl.Handle, TCM_SETITEM, Index, Longint(@TCItem)) = 0 then TabControlError(Format(sTabFailSet, [S, Index]));
  if FTabControl.OwnCalc then FTabControl.DrawingLock := True;
  FTabControl.TabsChanged;
  if FTabControl.OwnCalc then FTabControl.DrawingLock := False;
end;

procedure TsTabStrings.PutObject(Index: Integer; AObject: TObject);
var
  TCItem: TTCItem;
begin
  TCItem.mask := TCIF_PARAM;
  TCItem.lParam := Longint(AObject);
  if SendMessage(FTabControl.Handle, TCM_SETITEM, Index, Longint(@TCItem)) = 0 then TabControlError(Format(sTabFailSetObject, [Index]));
end;

procedure TsTabStrings.Insert(Index: Integer; const S: string);
const
  RTL: array[Boolean] of LongInt = (0, TCIF_RTLREADING);
var
  TCItem: TTCItem;
begin
  TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or TCIF_IMAGE;
  TCItem.pszText := PChar(S);
  TCItem.iImage := FTabControl.GetImageIndex(Index);
  if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index, Longint(@TCItem)) < 0 then TabControlError(Format(sTabFailSet, [S, Index]));

  if FTabControl.OwnCalc then FTabControl.DrawingLock := True;
  FTabControl.TabsChanged;
  if FTabControl.OwnCalc then FTabControl.DrawingLock := False;
end;

procedure TsTabStrings.SetUpdateState(Updating: Boolean);
begin
  FTabControl.FUpdating := Updating;
  SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  if not Updating then begin
    FTabControl.TabsChanged;
    FTabControl.FCommonData.Invalidate;
  end;
end;

{ TsCustomTabControl }

procedure TsCustomTabControl.AdjustClientRect(var Rect: TRect);
begin
  Rect := DisplayRect;
  inherited AdjustClientRect(Rect);
end;

procedure TsCustomTabControl.AfterConstruction;
begin
  inherited;
  CommonData.Loaded;
end;

function TsCustomTabControl.CanChange: Boolean;
begin
  Result := True;
  if Assigned(FOnChanging) then FOnChanging(Self, Result);
end;

function TsCustomTabControl.CanShowTab(TabIndex: Integer): Boolean;
begin
  Result := True;
end;

procedure TsCustomTabControl.Change;
var
  Form: TCustomForm;
begin
  if Assigned(FOnChange) then FOnChange(Self);
  if csDesigning in ComponentState then begin
    Form := GetParentForm(Self);
    if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  end;
end;

procedure TsCustomTabControl.CMDialogChar(var Message: TCMDialogChar);
var
  I: Integer;
begin
  for I := 0 to FTabs.Count - 1 do begin