spagecontrol.pas

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

unit sPageControl;
{$I sDefs.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, sConst, ExtCtrls, sPanel, sGraphUtils, sUtils, ImgList,
  Consts, ComStrs, CommCtrl, sVclUtils, sGradient, sTabControl, sCommonData;

type
  TsPageControl = class;

  TsTabSheet = class(TCustomControl)
  private
    FImageIndex: TImageIndex;
    FPageControl: TsPageControl;
    FTabVisible: Boolean;
    FTabShowing: Boolean;
    FOnHide: TNotifyEvent;
    FOnShow: TNotifyEvent;
    FCommonData: TsCommonData;
    FHighlighted: Boolean;
    function GetPageIndex: Integer;
    function GetTabIndex: Integer;
    procedure SetHighlighted(Value: Boolean);
    procedure SetImageIndex(Value: TImageIndex);
    procedure SetPageControl(APageControl: TsPageControl);
    procedure SetPageIndex(Value: Integer);
    procedure SetTabShowing(Value: Boolean);
    procedure SetTabVisible(Value: Boolean);
    procedure UpdateTabShowing;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
    procedure WMEraseBkGND (var Message: TWMPaint); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DoHide; dynamic;
    procedure DoShow; dynamic;
    procedure ReadState(Reader: TReader); override;
    procedure Loaded; override;
  public
    BGChanged : boolean;
    procedure AfterConstruction; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure WndProc (var Message: TMessage); override;
    procedure VisibleChanging; override;

    property PageControl: TsPageControl read FPageControl write SetPageControl;
    property TabIndex: Integer read GetTabIndex;
    property Align;
    property Highlighted: Boolean read FHighlighted write SetHighlighted default False;
  published
    property Caption;
    property CommonData : TsCommonData read FCommonData write FCommonData;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default 0;
    property Left stored False;
    property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;
    property TabVisible: Boolean read FTabVisible write SetTabVisible default True;
    property Top stored False;
    property Visible stored False;
    property Width stored False;
    property OnHide: TNotifyEvent read FOnHide write FOnHide;
    property OnShow: TNotifyEvent read FOnShow write FOnShow;
  end;

  TsPageControl = class(TsCustomTabControl)
  private
    FPages: TList;
    FActivePage: TsTabSheet;
    FNewDockSheet: TsTabSheet;
    FUndockingPage: TsTabSheet;
    procedure ChangeActivePage(Page: TsTabSheet);
    procedure DeleteTab(Page: TsTabSheet; Index: Integer);
    function GetActivePageIndex: Integer;
    function GetDockClientFromMousePos(MousePos: TPoint): TControl;
    function GetPage(Index: Integer): TsTabSheet;
    function GetPageCount: Integer;
    procedure InsertPage(Page: TsTabSheet);
    procedure InsertTab(Page: TsTabSheet);
    procedure MoveTab(CurIndex, NewIndex: Integer);
    procedure RemovePage(Page: TsTabSheet);
    procedure SetActivePage(Page: TsTabSheet);
    procedure SetActivePageIndex(const Value: Integer);
    procedure UpdateTab(Page: TsTabSheet);
    procedure UpdateTabHighlights;
    procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMDockClient(var Message: TCMDockClient); message CM_DOCKCLIENT;
    procedure CMDockNotification(var Message: TCMDockNotification); message CM_DOCKNOTIFICATION;
    procedure CMUnDockClient(var Message: TCMUnDockClient); message CM_UNDOCKCLIENT;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  protected
    function CanShowTab(TabIndex: Integer): Boolean; override;
    procedure Change; override;
    procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;
    procedure DockOver(Source: TDragDockObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;
    procedure DoRemoveDockClient(Client: TControl); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetImageIndex(TabIndex: Integer): Integer; override;
    function GetPageFromDockClient(Client: TControl): TsTabSheet;
    procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override;
    procedure Loaded; override;
    procedure SetChildOrder(Child: TComponent; Order: Integer); override;
    procedure ShowControl(AControl: TControl); override;
    procedure UpdateActivePage; virtual;

    procedure WMPaint (var Message: TWMPaint); message WM_PAINT;
    procedure DrawSkinTab(Index: Integer; State : integer); override;
    procedure WndProc (var Message: TMessage); override;
  public
    Skinable : boolean;
    procedure AfterConstruction; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindNextPage(CurPage: TsTabSheet; GoForward, CheckTabVisible: Boolean): TsTabSheet;
    procedure SelectNextPage(GoForward: Boolean);
    property ActivePageIndex: Integer read GetActivePageIndex write SetActivePageIndex;
    property PageCount: Integer read GetPageCount;
    property Pages[Index: Integer]: TsTabSheet read GetPage;
    property ScrollOpposite;
    property Style;
    property RaggedRight;
  published
    property ActivePage: TsTabSheet read FActivePage write SetActivePage;
    property Align;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Images;
    property MultiLine;
    property OwnerDraw;
    property ParentBiDiMode;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabHeight;
    property TabOrder;
    property TabStop;
    property TabPosition;
    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;

implementation

uses sStyleSimply, sDefaults, sBorders, sMaskData, math, sSkinProps, sAlphaGraph,
  sMessages;

{ TsTabSheet }

constructor TsTabSheet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCommonData := TsCommonData.Create(Self, False);
  FCommonData.COC := COC_TsTabSheet;
  Align := alClient;
  ControlStyle := ControlStyle + [csSetCaption] - [csOpaque];
  Visible := False;
  FTabVisible := True;
  FHighlighted := False;
end;

destructor TsTabSheet.Destroy;
begin
  if FPageControl <> nil then begin
    if FPageControl.FUndockingPage = Self then FPageControl.FUndockingPage := nil;
    FPageControl.RemovePage(Self);
  end;
  if Assigned(FCommonData) then FreeAndNil(FCommonData);
  inherited Destroy;
end;

procedure TsTabSheet.DoHide;
begin
  if Assigned(FOnHide) then FOnHide(Self);
end;

procedure TsTabSheet.DoShow;
begin
  if Assigned(FOnShow) then FOnShow(Self);
end;

function TsTabSheet.GetPageIndex: Integer;
begin
  if FPageControl <> nil then
    Result := FPageControl.FPages.IndexOf(Self) else
    Result := -1;
end;

function TsTabSheet.GetTabIndex: Integer;
var
  I: Integer;
begin
  Result := 0;
  if not Assigned(Self) then Exit;
  if not FTabShowing then begin
    Dec(Result)
  end
  else begin
    for I := 0 to PageIndex - 1 do begin
      if TsTabSheet(FPageControl.FPages[I]).FTabShowing then begin
        Inc(Result);
      end;
    end;
  end;
end;

procedure TsTabSheet.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.WindowClass.style := Params.WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TsTabSheet.ReadState(Reader: TReader);
begin
  inherited ReadState(Reader);
  if Reader.Parent is TsPageControl then PageControl := TsPageControl(Reader.Parent);
end;

procedure TsTabSheet.SetImageIndex(Value: TImageIndex);
begin
  if FImageIndex <> Value then begin
    FImageIndex := Value;
    if FTabShowing then FPageControl.UpdateTab(Self);
  end;
end;

procedure TsTabSheet.SetPageControl(APageControl: TsPageControl);
begin
  if FPageControl <> APageControl then begin
    if FPageControl <> nil then FPageControl.RemovePage(Self);
    Parent := nil;
    Parent := APageControl;
    if APageControl <> nil then APageControl.InsertPage(Self);
  end;
end;

procedure TsTabSheet.SetPageIndex(Value: Integer);
var
  I, MaxPageIndex: Integer;
begin
  if FPageControl <> nil then begin
    MaxPageIndex := FPageControl.FPages.Count - 1;
    if Value > MaxPageIndex then raise EListError.CreateResFmt(@SPageIndexError, [Value, MaxPageIndex]);
    I := TabIndex;
    FPageControl.FPages.Move(PageIndex, Value);
    if I >= 0 then FPageControl.MoveTab(I, TabIndex);
  end;
end;

procedure TsTabSheet.SetTabShowing(Value: Boolean);
var
  Index: Integer;
begin
  if FTabShowing <> Value then begin
    if Value then begin
      FTabShowing := True;
      FPageControl.InsertTab(Self);
    end
    else begin
      Index := TabIndex;
      FTabShowing := False;
      FPageControl.DeleteTab(Self, Index);
    end;
  end;
end;

procedure TsTabSheet.SetTabVisible(Value: Boolean);
begin
  if FTabVisible <> Value then begin
    FTabVisible := Value;
    UpdateTabShowing;
//    sStyle.Invalidate;
  end;
end;

procedure TsTabSheet.UpdateTabShowing;
begin
  SetTabShowing((FPageControl <> nil) and FTabVisible);
end;

procedure TsTabSheet.CMTextChanged(var Message: TMessage);
begin
  if FTabShowing then FPageControl.UpdateTab(Self);
end;

procedure TsTabSheet.CMShowingChanged(var Message: TMessage);
begin
  inherited;
  if Showing then begin
    try
      DoShow
    except
      Application.HandleException(Self);
    end;
  end else if not Showing then begin
    try
      DoHide;
    except
      Application.HandleException(Self);
    end;
  end;
end;

procedure TsTabSheet.SetHighlighted(Value: Boolean);
begin
  if not (csReading in ComponentState) then
    SendMessage(PageControl.Handle, TCM_HIGHLIGHTITEM, TabIndex,
      MakeLong(Word(Value), 0));
  FHighlighted := Value;
end;

procedure TsTabSheet.Paint;
begin
  if not Assigned(Parent) or (csDestroying in Parent.ComponentState) or (csDestroying in ComponentState) or not (Visible or (csDesigning in ComponentState)) then Exit;
  if Assigned(PageControl) and PageControl.Skinable then begin
    BitBlt(Canvas.Handle, 0, 0, Width, Height, PageControl.FCommonData.FCacheBmp.Canvas.Handle, Left, Top, SRCCOPY);

//    RepaintsControls(Self, False);   //!!!
//    PaintPassiveControls(Self);
  end else begin
    inherited;
  end;
end;

procedure TsTabSheet.WndProc(var Message: TMessage);
begin
  if Assigned(FCommonData) then begin
    FCommonData.WndProc(Message);
    if FCommonData.Skinned then case Message.Msg of
      CM_VISIBLECHANGED : begin
//        SendMessage(Handle, CM_INVALIDATE, 0, 0);
//        SendMessage(Handle, WM_NCPAINT, 0, 0);
      end;
      WM_SIZE : begin
        Repaint;
      end;
      WM_MOVE : begin
        Repaint;
      end;
//      SM_SETBGCHANGED : if not (csLoading in ComponentState) then
//        FCommonData.BGChanged := True;
      SM_GETCACHE : begin
        Message.Result := 1;
        if not Assigned(PageControl) then Exit;
        GlobalCacheInfo.X := PageControl.PageRect.Left;
        GlobalCacheInfo.Y := PageControl.PageRect.Top;
        GlobalCacheInfo.Bmp := PageControl.FCommonData.FCacheBmp;
        GlobalCacheInfo.Ready := True;
      end;
    end;
  end;
  if Message.Result <> 1 then inherited;
end;

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