www.pudn.com > mfcdraw.zip > atabctrl.pas

{************* 
 * 
 * Project....: Experiences and Examples 
 * File.......: ATabCtrl.pas 
 * Created by : Anton A. Mints 
 * Date.......: 1 December 1996 
 * Purpose....: Tab Control with glyph on the tabs. 
 * 
 * $Archive: /delphi experiences/tcontrol with pictures/atabctrl.pas $ 
 * 
 * $History: atabctrl.pas $ 
 *  
 * *****************  Version 1  ***************** 
 * User: Anton        Date: 12/21/96   Time: 8:37p 
 * Created in $/delphi experiences/tcontrol with pictures 
 * My own developed cool component 
 * 
 *************} 
 
unit 
  ATabCtrl; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  ComCtrls, CommCtrl, StdCtrls, Tabs; 
 
type 
  TCEODrawTabEvent = procedure (Sender: TObject; 
    TabCanvas: TCanvas; const RectFg, RectBg: TRect; 
    Index: Integer; ActiveTab: Boolean) of object; 
 
  TCEOSheetColor = (scDefault, scSameAsTab); 
 
{ TCEOTabControl } 
  TCEOTabControl = class (TTabControl) 
  private 
    FStyle: TTabStyle; 
    FSheetColor: TColor; 
    FCanvas: TCanvas; 
    FImages: TImageList; 
    FImageChangeLink: TChangeLink; 
 
    FTabActiveColor: TColor; 
    FTabActiveFont: TFont; 
    FSheetStyle: TCEOSheetColor; 
 
    FOnDrawTab: TCEODrawTabEvent; 
 
    procedure ImageListChange (Sender: TObject); 
    procedure SetImages (Value: TImageList); 
 
    procedure SetImage (Index: Integer; imIndex: Integer); 
    function GetImage (Index: Integer): Integer; 
 
    procedure SetStyle (Value: TTabStyle); 
    procedure SetTabActiveColor (Value: TColor); 
    procedure SetTabActiveFont (Value: TFont); 
    procedure SetSheetStyle (Value: TCEOSheetColor); 
 
    procedure CNDrawTab(var Message: TWMDrawItem); message CN_DRAWITEM; 
    procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED; 
    procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED; 
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; 
 
  protected 
    procedure CreateParams(var Params: TCreateParams); override; 
 
    procedure Invalidate; override; 
    procedure Change; override; 
 
  public 
    constructor Create (AOwner: TComponent); override; 
    destructor Destroy; override; 
 
    procedure DefaultDrawTab (RectFg, RectBg: TRect; 
      Index: Integer; ActiveTab: Boolean); 
 
    procedure DrawTab (TabCanvas: TCanvas; const RectFg, RectBg: TRect; 
      Index: Integer; ActiveTab: Boolean); virtual; 
 
    function GetSheetRect: TRect; virtual; 
 
    property Image[Index: Integer]: Integer read GetImage write SetImage; 
    property Canvas: TCanvas read FCanvas; 
 
  published 
    property Images: TImageList read FImages write SetImages; 
    property Style: TTabStyle read FStyle write SetStyle; 
 
    property ParentColor; 
    property Color; 
 
    property TabActiveColor: TColor read FTabActiveColor 
        write SetTabActiveColor; 
 
    property TabActiveFont: TFont read FTabActiveFont 
        write SetTabActiveFont; 
 
    property SheetStyle: TCEOSheetColor read FSheetStyle 
        write SetSheetStyle; 
 
    property OnDrawTab: TCEODrawTabEvent read FOnDrawTab write FOnDrawTab; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('Additional', [TCEOTabControl]); 
end; 
 
{*******************************************************************} 
{*                     CLASS TCEOTabControl                        *} 
{*******************************************************************} 
 
constructor TCEOTabControl.Create (AOwner: TComponent); 
begin 
  inherited Create (AOwner); 
  FImageChangeLink := TChangeLink.Create; 
  FImageChangeLink.OnChange := ImageListChange; 
 
  FCanvas := TControlCanvas.Create; 
  TControlCanvas(FCanvas).Control := Self; 
 
  FTabActiveFont := TFont.Create; 
  FTabActiveFont.Assign (Font); 
  FTabActiveColor := Color; 
  FSheetColor := Color; 
end; 
 
destructor TCEOTabControl.Destroy; 
begin 
  FTabActiveFont.Free; 
  FCanvas.Free; 
  FImageChangeLink.Free; 
  inherited Destroy; 
end; 
 
 
{************* 
* Name.......: CreateParams 
* Description: Set Owner Draw style if we have to 
*} 
procedure TCEOTabControl.CreateParams(var Params: TCreateParams); 
begin 
  inherited CreateParams(Params); 
 
  if ( FStyle = tsOwnerDraw ) then 
    Params.Style := Params.Style or TCS_OWNERDRAWFIXED; 
end; 
 
 
{************* 
* Name.......: Invalidate 
*} 
procedure TCEOTabControl.Invalidate; 
begin 
  LockWindowUpdate (Canvas.Handle); 
  inherited Invalidate; 
  LockWindowUpdate (0); 
end; 
 
 
{************* 
* Name.......: Change 
* Description: Redraw sheet area if we have AsTabColot setting. 
*} 
procedure TCEOTabControl.Change; 
var 
  Rect : TRect; 
begin 
  inherited Change; 
  if ( FSheetStyle <> scDefault ) then 
  begin 
    Rect := GetSheetRect; 
    InvalidateRect (Handle, @Rect, True); 
  end; 
end; 
 
 
{************* 
* Name.......: ImageListChange 
* Description: Be called whenever a change in the ImageList occurs to 
*             notify TabControl about the changes. 
*} 
procedure TCEOTabControl.ImageListChange(Sender: TObject); 
begin 
  if HandleAllocated then 
    SendMessage(Handle, TCM_SETIMAGELIST, 0, Longint(TImageList(Sender).Handle)); 
end; 
 
 
{************* 
* Name.......: SetImages 
* Description: Assign ImageList to internal class variable and register 
*              TChangeLink object. 
*} 
procedure TCEOTabControl.SetImages (Value: TImageList); 
begin 
  if Assigned (FImages) then 
    Images.UnRegisterChanges(FImageChangeLink); 
 
  FImages := Value; 
 
  if Assigned (FImages) then 
    begin 
      Images.RegisterChanges (FImageChangeLink); 
      SendMessage(Handle, TCM_SETIMAGELIST, 0, Longint(Images.Handle)); 
    end 
  else 
    SendMessage(Handle, TCM_SETIMAGELIST, 0, Longint(0)); 
end; 
 
 
{************* 
* Name.......: SetImage 
* Description: Display image from ImageList on Index tab. 
*} 
procedure TCEOTabControl.SetImage (Index: Integer; imIndex: Integer); 
var 
  imItem: TTCItem; 
begin 
  imItem.iImage := imIndex; 
  imItem.mask := TCIF_IMAGE; 
  SendMessage (Handle, TCM_SETITEM, Index, Longint(@imItem)); 
end; 
 
 
{************* 
* Name.......: GetImage 
*} 
function TCEOTabControl.GetImage (Index: Integer): Integer; 
var 
  imItem: TTCItem; 
begin 
  if Assigned (FImages) then 
    begin 
      imItem.mask := TCIF_IMAGE; 
      SendMessage (Handle, TCM_GETITEM, Index, Longint(@imItem)); 
      Result := imItem.iImage; 
    end 
  else 
    Result := -1 
end; 
 
 
{************* 
* Name.......: SetStyle 
*} 
procedure TCEOTabControl.SetStyle (Value: TTabStyle); 
begin 
  // If style wasn't changed, do nothing 
  if ( Style <> Value ) then 
  begin 
    FStyle := Value; 
    RecreateWnd; 
  end; 
end; 
 
 
{************* 
* Name.......: SetTabActiveColor 
*} 
procedure TCEOTabControl.SetTabActiveColor (Value: TColor); 
begin 
  if FTabActiveColor <> Value then 
  begin 
    FTabActiveColor := Value; 
    Invalidate; 
  end; 
end; 
 
 
{************* 
* Name.......: SetTabActiveFont 
*} 
procedure TCEOTabControl.SetTabActiveFont (Value: TFont); 
begin 
  FTabActiveFont.Assign (Value); 
  Invalidate; 
end; 
 
 
{************* 
* Name.......: SetSheetColor 
*} 
procedure TCEOTabControl.SetSheetStyle (Value: TCEOSheetColor); 
begin 
  if ( FSheetStyle <> Value ) then 
  begin 
    FSheetStyle := Value; 
    Invalidate; 
  end; 
end; 
 
 
{************* 
* Name.......: GetSheetRect 
* Description: Return sheet rectangle 
*} 
function TCEOTabControl.GetSheetRect: TRect; 
var 
  TabRect: TRect; 
 
begin 
  // Get tab rectangle 
  SendMessage (Handle, TCM_GETITEMRECT, 0, Longint(@TabRect)); 
  // Calculate sheet rectangle 
  Result := Rect (2, TabRect.Bottom - TabRect.Top + 4, Width-3, Height-2); 
end; 
 
 
{************* 
* Name.......: DefaultDrawTab 
*} 
procedure TCEOTabControl.DefaultDrawTab (RectFg, RectBg: TRect; 
  Index: Integer; ActiveTab: Boolean); 
 
  {************* 
  * Name.......: DrawTabBkGround 
  *} 
  procedure DrawTabBkGround; 
  begin 
    Canvas.FillRect (RectBg); 
  end; 
 
  {************* 
  * Name.......: DrawTabImage 
  *} 
  procedure DrawTabImage; 
  var 
    ImageIndex: Integer; 
  begin 
    // Get image accotiateg with the current tab 
    ImageIndex := GetImage (Index); 
 
    // Draw image on tab 
    if ( ImageIndex >= 0 ) then 
    begin 
      FImages.Draw (Canvas, RectFg.Left + 6, 
        RectFg.Top + ((RectFg.Bottom - RectFg.Top - FImages.Height) div 2), ImageIndex); 
      RectFg.Left := RectFg.Left + 6 + FImages.Width; 
    end; 
  end; 
 
  {************* 
  * Name.......: DrawTabText 
  *} 
  procedure DrawTabText; 
  begin 
    DrawText (Canvas.Handle, PChar(Tabs[Index]), 
      Length(Tabs[Index]), RectFg, DT_SINGLELINE or DT_CENTER or DT_VCENTER); 
  end; 
 
  {************* 
  * Name.......: DrawTabSheet 
  *} 
  procedure DrawTabSheet; 
  begin 
    if ( FSheetStyle = scDefault ) then 
      FSheetColor := Color 
    else 
      FSheetColor := Canvas.Brush.Color; 
    Canvas.Brush.Color := FSheetColor; 
    Canvas.FillRect (GetSheetRect); 
  end; 
 
begin 
{ 
  if ActiveTab then 
  begin 
    if ( FSheetStyle = scDefault ) then 
      FSheetColor := Color 
    else 
      FSheetColor := Canvas.Brush.Color; 
  end; 
} 
  if ( Index < 0 ) then Exit; 
 
  DrawTabBkGround; 
  DrawTabImage; 
  DrawTabText; 
  if ActiveTab then DrawTabSheet; 
end; 
 
 
{************* 
* Name.......: DrawTab 
* Description: Call event handler if was set, 
*             or use default draw method to draw tab 
*} 
procedure TCEOTabControl.DrawTab (TabCanvas: TCanvas; const RectFg, RectBg: TRect; 
  Index: Integer; ActiveTab: Boolean); 
begin 
  if Assigned(FOnDrawTab) then 
    FOnDrawTab (Self, Canvas, RectFg, RectBg, Index, ActiveTab) 
  else 
    DefaultDrawTab (RectFg, RectBg, Index, ActiveTab); 
end; 
 
 
{************* 
* Name.......: CNDrawTab (Message CN_DRAWTAB) 
* Description: This message is sent when eacth tab needs to be repainted. 
*} 
procedure TCEOTabControl.CNDrawTab (var Message: TWMDrawItem); 
var 
  SaveIndex: Integer; 
  State: TOwnerDrawState; 
  RectFg, RectBg: TRect; 
  IsActiveTab: Boolean; 
 
  function AdjustRect (Rect: TRect; ALeft, ATop, ARight, ABottom: Integer): TRect; 
  begin 
    Result.Left := Rect.Left + ALeft; 
    Result.Top := Rect.Top + ATop; 
    Result.Right := Rect.Right + ARight; 
    Result.Bottom := Rect.Bottom + ABottom; 
  end; 
 
begin 
  with Message.DrawItemStruct^ do 
  begin 
    SaveIndex := SaveDC(hDC); 
    FCanvas.Handle := hDC; 
 
    { 
    State := []; 
    if (itemState and ODS_SELECTED) = ODS_SELECTED then 
      State := State + [odSelected]; 
    if ( itemState and ODS_DISABLED ) = ODS_DISABLED then 
      State := State + [odDisabled]; 
    if ( itemState and ODS_FOCUS ) = ODS_FOCUS then 
      State := State + [odFocused]; 
    } 
 
    // Define if we draw the Active tab 
    if ( itemID < 0 ) then 
      IsActiveTab := False 
    else 
      IsActiveTab := ( itemID = TabIndex ); 
 
    if IsActiveTab then 
      begin 
        FCanvas.Font := TabActiveFont; 
        FCanvas.Brush.Color := TabActiveColor; 
      end 
    else 
      begin 
        FCanvas.Font := Font; 
        FCanvas.Brush.Color := Color; 
      end; 
 
    FCanvas.Brush.Style := bsSolid; 
 
 
    // Adjust the rectangle size a little bit 
    if ( IsActiveTab ) then 
      begin 
        RectFg := AdjustRect (rcItem, 2, 1, -2, -3); 
        RectBg := AdjustRect (rcItem, 0, 0,  0,  0); 
      end 
    else 
      begin 
        RectFg := AdjustRect (rcItem, -2, 0, 0, 3); 
        RectBg := AdjustRect (rcItem, -2, 1, 0, 2); 
      end; 
 
    // Draw tab 
    DrawTab (FCanvas, RectFg, RectBg, itemID, IsActiveTab); 
 
    FCanvas.Handle := 0; 
    RestoreDC(hDC, SaveIndex); 
  end; 
  Message.Result := 1; 
end; 
 
 
{************* 
* Name.......: CMParentColorChanged (Message CM_PARENTCOLORCHANGED) 
*} 
procedure TCEOTabControl.CMParentColorChanged (var Message: TMessage); 
var 
  IsActiveColorEqual: Boolean; 
 
begin 
  IsActiveColorEqual := ( FTabActiveColor = Color ); 
 
  inherited; 
 
  // If the active tab color was equal tab control color, 
  //change active tab color too. 
  if IsActiveColorEqual and ( FTabActiveColor <> Color ) then 
  begin 
    FTabActiveColor := Color; 
    FSheetColor := Color; 
  end; 
 
  Invalidate; 
end; 
 
 
{************* 
* Name.......: CMParentFontChanged (Message CM_PARENTFONTCHANGED) 
*} 
procedure TCEOTabControl.CMParentFontChanged (var Message: TMessage); 
var 
  IsActiveFontEqual: Boolean; 
 
  function IsFontEqual (Font1, Font2: TFont): Boolean; 
  begin 
    Result := ( Font1.Name = Font2.Name ) and 
      ( Font1.Size = Font2.Size ) and 
      ( Font1.Style = Font2.Style ) and 
      ( Font1.Color  = Font2.Color ); 
  end; 
 
begin 
  IsActiveFontEqual := IsFontEqual (FTabActiveFont, Font); 
 
  inherited; 
 
  // If the active tab font was equal tab control font, 
  //change active tab font too. 
  if IsActiveFontEqual and not IsFontEqual (FTabActiveFont, Font) then 
    FTabActiveFont.Assign (Font); 
 
  Invalidate; 
end; 
 
 
{************* 
* Name.......: WMEraseBkgnd (Message WM_ERASEBKGND) 
*} 
procedure TCEOTabControl.WMEraseBkgnd (var Message: TWMEraseBkgnd); 
var 
  SaveIndex: Integer; 
 
begin 
  SaveIndex := SaveDC(Message.DC); 
  FCanvas.Handle := Message.DC; 
  FCanvas.Font := Font; 
  FCanvas.Brush.Color := FSheetColor; 
  FCanvas.Brush.Style := bsSolid; 
  FillRect (FCanvas.Handle, ClientRect, Parent.Brush.Handle); 
  FillRect (FCanvas.Handle, GetSheetRect, FCanvas.Brush.Handle); 
  FCanvas.Handle := 0; 
  RestoreDC(Message.DC, SaveIndex); 
  Message.Result := 1; 
end; 
 
end.