Botões Extras Na Barra De Título

[Thales Pontes Martins]

Aí está o componente para colocar botões extras na barra de título que suporta XP_THEMES.

Se antes quiserem ver o resultado final tem um programa exemplo com código fonte em Delphi 2006(RAR) neste Link.

Tem somente o executável neste Link

Se forem instalar o componente lembrem-se de acrescentar a linha que está como comentário->

Result:={(csDesigning in ComponentState)}false;

Troque para->

Result:=(csDesigning in ComponentState);

porque se não fizer isso podem ocorrer efeitos indesejáveis durante o tempo de desenho do programa. O componente é TCaptionButtons derivado de TComponent e existe somente para ser comportado pelo form como sendo componente. Dentro dele existe uma propriedade do tipo TCaptionButtonArray derivada de TCollection, que serve para fazer o controle do componente. E essa por sua vez tem uma coleção da classe TCaptionButton derivada de TCollectionItem compondo os items da coleção que tem como função armazenar os dados de cada botão acrescentado a lista. Qualquer problema mande MP. TCaptionButtonArray -> Propriedades -> ToBegin: Byte - Indica a índice do primeiro botão da lista, da direita pra esquerda. Default = 4. HintHideTime: Integer - Tempo em ms que demora para uma Hint associada a algum botão ser ocultada. Default = 5000; HintShowTime: Integer - Tempo em ms que demora para uma Hint aparecer depois que o mouse estaciona sob a área de um botão. Default = 1300. property Items[index: Integer]: TCaptionButton - Retorna um TCaptionButton da lista de botões no índice especificado. property SupportsThemes : boolean - Indica se a versão do Windows suporta Themes. property XPStyle : byte - Identifica qual tema XP está atualmente sendo usado pela janela: NO_THEME, XP_BLUE, XP_METALLIC ou XP_HOMESTEAD. Eventos -> OnThemeChange -> Ocorre quando há mudança de tema para o Form Owner do componente. Campos -> Bitmaps: array[1..8] of TBitmap - Bitmaps dos botões em todos os seus 8 possíveis estados quando está sendo feito uso de tema. Esse botões não possuem ícones desenhados. Bitmaps_:array[1..8] of TBitmap - Bitmaps dos botões em todos os seus 8 possíveis estados quando está sendo feito uso de tema. Esse botões possuem o ícone de minimizar para o Tray. IconColors : array[1..8] of TColor - Cores dos ícones do botão com o tema usado atualmente em todos os seus 8 estados. Usado para desenhar um ícone no botão. Lock : Cardinal - Mensagem que a aplicação não deve processar. Se for 0 serão processadas todas as mensagems. Usado para mudar várias propriedades que executam mensagems nos seu métodos de escrita, como WM_NCPAINT, e não ter queda de performance. Métodos -> Function add : TCaptionButton; - Cria uma nova instancia de TCaptionButton e adiciona sua referencia a lista. procedure UnLock; - Seta o campo Lock para 0; Function GetButtonRect(index : byte; rec : TRect; theme : cardinal; OffSet : integer; XS, YS: integer) : TRect; - Pega o retangulo que um botão correspondente aos parametros fornecidos ocupa atualmente. Onde "index" é o índice do botão na lista, "rec" é o retangulo do form, "theme" é o handle do tema atual, "OffSet" é quantos pixels o botão deve estar deslocado para a esquerda, "XS" é a largura do botão e "YS" é a altura do botão. Function GetXPStyle(Val : TRGB) : byte; - Retorna a constante que identifica qual tema XP está atualmente sendo usado pela janela mediante fornecimento de uma cor do fundo do botão: NO_THEME, XP_BLUE, XP_METALLIC ou XP_HOMESTEAD. Não é necessário, apenas leia a propriedade XPStyle. Function RemoveIcon(Bm : TBitmap; FillR : PRect = nil) : TBtnInfo; - Remove o ícone de minimizar do bitmap com o botão devidamente desenhado. procedure DrawSingleButton(index: integer; DC, stat : cardinal; fast : boolean = true); - Desenha na barra o botão especificado por "index" no Device Context "DC", no estado "stat", com método economico ou não dependendo de "fast". function Perform(Msg, WParam, LParam : integer) : integer; - Executa a mensagem "Msg" com WParam "WParam", LParam "LParam" e retorna o resultado do processamento da mensagem pelo form ou pelo componente. procedure UpdateBitmaps; - Atualiza os bitmaps. Usado no caso de a aparencia dos botões mudar. TCaptionButton -> Propriedades -> OwnerDrawed : boolean - Indica se o botão é desenhado pelo Owner. Caso true, um bitmap será passado a um Event Handler para que esse possa desenhar o ícone no botão. Caso false, será desenhado o botão de minimizar para o Tray. Default = false. Enabled : boolean - Indica se o botão está habilitado. Default = true. OffSet : integer - Indica a distancia em pixels que o botão deve estar do botão a sua direita. Default = 0. Visible : boolean - Indica se o botão está visível. Default = true; Hint : string - Indica o texto que deverá ser mostrado na Hint do botão. Só será mostrada a Hint se a propriedade ShowHint for true. ShowHint : boolean - Indica se deverá ser mostrada a Hint do Botão. Default = false. PopUpMenu : TPopUpMenu - Referencia a uma instancia de TPopupMenu que deverá aparecer quando o usuário pressionar o botão direito do mouse. Eventos -> OnClick - Ocorre quando o usuário clica no botão. OnDraw - Ocorre quando é desenhado um botão. Um TBitmap é passado como parametro para esse evento para ser desenhado nele o ícone do botão. O Bitmap inicialmente conterá apenas o fundo do botão. Campos -> Rect : TRect - Especifica o retangulo do botão em relação a área não cliente do Form. State : Cardinal - Especifica o estado atual do botão. Listagem da Unit do Componente -> UCaptionButton.Pas

unit UCaptionButton;
{
* Componente CaptionButtons.

* Descrição: Componente que permite adicioncar botões
  extras na barra de título suportando XP_THEMES.

* Autor: Thales Pontes Martins.
  thalespo@terra.com.br

* Freeware: Este código pode ser ditribuído livremente desde
  que sejam mantidas essas informações na íntegra.

* Dezembro de 2006.
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, uxtheme, StdCtrls, Menus{, UMessageStr};

const
  NO_THEME = byte(0);
  XP_BLUE = byte(1);
  XP_METALLIC = byte(2);
  XP_HOMESTEAD = byte(3);

  BT_NORMAL = cardinal(1);
  BT_HOT = cardinal(2);
  BT_PUSHED = cardinal(3);
  BT_DISABLED = cardinal(4);
  BT_INORMAL = cardinal(5);
  BT_IHOT = cardinal(6);
  BT_IPUSHED = cardinal(7);
  BT_IDISABLED = cardinal(8);

  HTCUSTOMBUTTON = Cardinal(65);

  BTTIMERID = cardinal(33998015);
  HIDEHINTID = cardinal(99600342);

  IconDif = 27;

type
  TCaptionButtonDrawEvent = procedure(Sender : TObject; bmp : TBitmap; state, index : cardinal) of object;
  TCaptionButtonClickEvent = procedure(Sender : TObject; index : integer) of object;

  TCaptionButtonArray = class;
  TCaptionButtons = class;
  TCaptionButton = class;

  TRGB = record
    r, g, b, info : byte;
  end;

  TBtnInfo = record
    Rect : TRect;
    IconColor : TColor;
  end;

  TCaptionButtons = class(TComponent)
  private
    _Buttons : TCaptionButtonArray;
    function des : boolean;
  public
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;
  published
    Property Buttons : TCaptionButtonArray read _Buttons;
  end;

  TCaptionButtonArray = class(TCollection)
  private
    _SupportsThemes, ThemeChanged, DoThEvt : boolean;
    ParentWndProc : TWndMethod;
    _OnThemeChange : TNotifyEvent;
    OwnerForm : TForm;
    Owner : TCaptionButtons;
    Theme : THANDLE;
    _XPStyle : byte;
    Selected, Pushed, RPushed, _HintShowTime, _HintHideTime : integer;
    _ToBegin : Byte;
    DrAux : TBitmap;
    BtnH, BtnW : integer;
    TimerSet, HintShow, HideSet : Boolean;
    HintWindow : THintWindow;
    procedure SetToBegin(AValue : byte);
  Protected
    Function Add : TCaptionButton;
    Function GetItem(Index : integer) : TCaptionButton;
    Procedure SetItem(Index : Integer; Item : TCaptionButton);
    //Messages
    procedure ON_WM_NCPAINT(var msg : TMessage);
    Procedure ON_WM_NCHITTEST(var msg : TMessage);
    procedure ON_WM_NCLBUTTONDOWN(var msg : TMessage);
    procedure ON_WM_NCLBUTTONUP(var msg : TMessage);
    procedure ON_WM_NCRBUTTONDOWN(var msg : TMessage);
    procedure ON_WM_NCRBUTTONUP(var msg : TMessage);
    procedure ON_WM_TIMER(var msg : TMessage);
    procedure ON_WM_NCMOUSELEAVE(var msg : TMessage);
  public
    bitmaps, bitmaps_ : array[1..8] of TBitmap;
    IconColors : array[1..8] of TColor;
    Lock : Cardinal;
    constructor Create(AForm : TForm; AOwner : TCaptionButtons);
    Destructor Destroy; Override;
    procedure WndProc(var msg : TMessage);
    procedure UnLock;
    Function GetButtonRect(index : byte; rec : TRect; theme : cardinal; OffSet : integer; XS, YS: integer) : TRect;
    Function GetXPStyle(Val : TRGB) : byte;
    Function RemoveIcon(Bm : TBitmap; FillR : PRect = nil) : TBtnInfo;
    procedure DrawSingleButton(index: integer; DC, stat : cardinal; fast : boolean = true);
    function Perform(Msg, WParam, LParam : integer) : integer;
    procedure UpdateBitmaps;
    property Items[Index: Integer]: TCaptionButton read GetItem write SetItem;
    property SupportsThemes : boolean read _SupportsThemes;
    property XPStyle : byte read _XPStyle;
  published
    property ToBegin : Byte read _Tobegin write SetToBegin;
    property HintHideTime : integer read _HintHideTime write _HintHideTime;
    property HintShowTime : integer read _HintShowTime write _HintShowTime;
    property OnThemeChange : TNotifyEvent read _OnThemeChange write _OnThemeChange;
  end;

  TCaptionButton = class(TCollectionItem)
  private
    _OnClick : TCaptionButtonClickEvent;
    _OnDraw : TCaptionButtonDrawEvent;
    _OwnerDrawed, _Enabled, _Visible, _ShowHint : Boolean;
    _PopUpMenu : TPopUpMenu;
    _OffSet : integer;
    _Hint : string;
    procedure SetOffset(AValue : integer);
    procedure SetEnabled(AValue : boolean);
    procedure SetVisible(AValue : boolean);
  public
    Rect : TRect;
    State : Cardinal;
    Constructor Create(Collection : TCollection); override;
    Destructor Destroy; override;
  published
    property OwnerDrawed : boolean read _OwnerDrawed write _OwnerDrawed;
    property Enabled : boolean read _Enabled write SetEnabled;
    property OffSet : integer read _OffSet write SetOffSet;
    property Visible : boolean read _Visible write SetVisible;
    property Hint : string read _Hint write _Hint;
    property ShowHint : boolean read _ShowHint write _ShowHint;
    property PopUpMenu : TPopUpMenu read _PopUpMenu write _PopUpMenu;
    property OnClick : TCaptionButtonClickEvent read _OnClick write _OnClick;
    property OnDraw : TCaptionButtonDrawEvent read _OnDraw write _OnDraw;
  end;

procedure register;

implementation

//Global fields used in debugging
{var
  NTime : cardinal;
  mês: TStringList;    }

procedure register;
begin
  RegisterComponents('Samples',[TCaptionButtons]);
end;

//this is a function that parses a TRect to a string
//Used in debug only
{Function RectToStr(r : TRect) : string;
begin
  Result:='L_'+inttostr(r.Left)+'   '+
          'R_'+inttostr(r.Right)+'   '+
          'T_'+inttostr(r.Top)+'   '+
          'B_'+inttostr(r.Bottom);
end;}

//These are the condition functions imitating the C++ ? operator
function s1(cond : boolean;vt,vf:byte) : byte;
begin
  if (cond) then result:=vt else result:=vf;
end;

function s4(cond : boolean;vt,vf:Cardinal) : Cardinal;
begin
  if (cond) then result:=vt else result:=vf;
end;

function s4_(cond : boolean;vt,vf:Integer) : Integer;
begin
  if (cond) then result:=vt else result:=vf;
end;

function sb(cond : boolean;vt,vf:boolean) : boolean;
begin
  if (cond) then result:=vt else result:=vf;
end;

constructor TCaptionButtons.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  _Buttons:=TCaptionButtonArray.create(TForm(AOwner),self);
end;

function TCaptionButtons.des : Boolean;
begin
  result:={(csDesigning in ComponentState)}false;
  //Pay attention, the (csDesigning in ComponentState) expression
  //will cause an exception if the component is being created
  //in runtime rather than being a installed component.
end;

Destructor TCaptionButtons.Destroy;
begin
  _Buttons.Destroy;
  inherited Destroy;
end;

Constructor TCaptionButton.Create(Collection: TCollection);
begin
  self.Collection:=Collection;
  _Enabled:=True;
  _Visible:=True;
  _OwnerDrawed:=False;
  _PopUpMenu:=nil;
  _OffSet:=0;
  _Hint:='';
  _ShowHint:=false;
end;

destructor TCaptionButton.Destroy;
begin
  inherited Destroy;
end;

procedure TCaptionButtonArray.UnLock;
begin
  Lock:=0;
end;

Constructor TCaptionButtonArray.Create(AForm : TForm; AOwner : TCaptionButtons);
var
  i : cardinal;
begin
  inherited Create(TCaptionButton);
  if (Owner.des) then exit;
  ThemeChanged:=True;
  Selected:=-1;
  Pushed:=-1;
  RPushed:=-1;
  _ToBegin:=4;
  TimerSet:=false;
  HintShow:=false;
  HideSet:=false;
  DoThEvt:=true;
  Lock:=0;
  _HintHideTime:=5000;
  _HintShowTime:=1300;
  _OnThemeChange:=nil;
  OwnerForm:=AForm;
  Owner:=AOwner;
  ParentWndProc:=OwnerForm.WindowProc;
  ThemeChanged:=True;
  _SupportsThemes:=InitThemeLibrary;//indicates if the windows version supports themes
  DrAux:=TBitmap.Create;
  if _supportsThemes then for I := 1 to 8 do
  begin
    Bitmaps[i]:=TBitmap.Create;
    Bitmaps_[i]:=TBitmap.Create;
  end;
  HintWindow:=THintWindow.Create(Owner);
  HintWindow.Color:=clInfoBk;
  OwnerForm.WindowProc:=WndProc;
end;

Destructor TCaptionButtonArray.Destroy;
var
  i : cardinal;
begin
  if _SupportsThemes then FreeThemeLibrary;
  OwnerForm.WindowProc:=ParentWndProc;
  DrAux.Destroy;
  if _SupportsThemes then for I := 1 to 8 do
  begin
    Bitmaps[i].Destroy;
    Bitmaps_[i].Destroy;
  end;
  HintWindow.Destroy;
  inherited Destroy;
end;

Function TCaptionButtonArray.Add : TCaptionButton;
begin
  result:=TCaptionButton(inherited Add);
end;

Function TCaptionButtonArray.GetItem(Index : Integer) : TCaptionButton;
begin
  Result:=TCaptionButton(inherited GetItem(Index));
end;

Procedure TCaptionButtonArray.SetItem(Index : integer; Item : TCaptionButton);
begin
  inherited SetItem(Index,Item);
end;

function TCaptionButtonArray.Perform(Msg, WParam, LParam: integer) : integer;
var
  ms : TMessage;
begin
  ms.Msg:=Msg;
  ms.WParam:=WParam;
  ms.LParam:=LParam;
  ms.Result:=0;
  WndProc(ms);
  result:=ms.Result;
end;

Function TCaptionButtonArray.GetXPStyle(Val : TRGB) : byte;
begin
  if (abs(integer(val.b)-((integer(val.r)+integer(val.g)) div 2)) < 30){Must be 17} then
  Result:=XP_METALLIC else
  begin
    if (val.b > s1((val.r>val.g),val.r,val.g)) then Result:=XP_BLUE else result:=XP_HOMESTEAD;
  end;
end;

procedure TCaptionButtonArray.UpdateBitmaps;
var
  p : PWideChar;
  st : string;
  r, r2, r3 : TRect;
  H, W : Integer;

procedure DoForTheme;
var
  i : cardinal;
  Aux : TColor;
  bm : tbitmap;
  icr: TRect;
  inf : TBtnInfo;
begin
  bm:=TBitmap.Create;
  bm.SetSize(r2.Right,r2.Bottom);

  DrawThemeBackGround(Theme,bm.canvas.Handle,WP_MINBUTTON,1,r2,nil);

  Aux:=bm.Canvas.Pixels[bm.Width div 2,bm.Height div 2];
  _XPStyle:=GetXPStyle(TRGB(Aux));
  icr:=RemoveIcon(bm).Rect;
  for i:=1 to 8 do
  begin
    bitmaps[i].SetSize(r2.Right,r2.Bottom);

    bitmaps[i].Canvas.Brush.Color:=Aux;
    bitmaps[i].Canvas.FillRect(r2);
    DrawThemeBackGround(Theme,bitmaps[i].Canvas.Handle,WP_MINBUTTON,i,r2,nil);

    //In the case u want to remove the corner 3 pixels add the
    //following lines that are commented.
    bitmaps[i].Canvas.pixels[0,0]:=0;
    //bitmaps[i].Canvas.pixels[0,1]:=0;
    //bitmaps[i].Canvas.pixels[1,0]:=0;

    bitmaps[i].Canvas.pixels[bitmaps[i].Width-1,bitmaps[i].Height-1]:=0;
    //bitmaps[i].Canvas.pixels[bitmaps[i].Width-1,bitmaps[i].Height-2]:=0;
    //bitmaps[i].Canvas.pixels[bitmaps[i].Width-2,bitmaps[i].Height-1]:=0;

    bitmaps[i].Canvas.pixels[bitmaps[i].Width-1,0]:=0;
    //bitmaps[i].Canvas.pixels[bitmaps[i].Width-1,1]:=0;
    //bitmaps[i].Canvas.pixels[bitmaps[i].Width-2,0]:=0;

    bitmaps[i].Canvas.pixels[0,bitmaps[i].Height-1]:=0;
    //bitmaps[i].Canvas.pixels[0,bitmaps[i].Height-2]:=0;
    //bitmaps[i].Canvas.pixels[1,bitmaps[i].Height-1]:=0;

    r:=bounds(0,0,icr.Right-icr.Left,icr.Bottom-icr.Top);
    bm.Canvas.CopyRect(r,bitmaps[i].Canvas,icr);
    inf:=RemoveIcon(bitmaps[i],@icr);
    IconColors[i]:=inf.IconColor;
    inf.Rect.Left:=trunc(r2.Right*0.55);
    inf.Rect.Right:=trunc(r2.Right*0.82);
    bitmaps_[i].Assign(bitmaps[i]);

    bitmaps_[i].Canvas.CopyRect(inf.Rect,bm.Canvas,r);
  end;
  if (_XPStyle = XP_METALLIC) then IconColors[8]:=IconColors[4];
  bm.Free;
end;

begin
  ThemeChanged:=False;
  if not(_SupportsThemes) then
  begin
    _XPStyle:=NO_THEME;
    exit;
  end;

  if (IsThemeActive) then
  begin
    st:='Window';
    p:=AllocMem((length(st)*2)+2);
    StringToWideChar(st,p,(length(st)*2)+2);
    Theme:=OpenThemeData(OwnerForm.handle,p);
    Freemem(p);
  end else Theme:=0;

  GetWindowRect(OwnerForm.Handle,r3);

  case OwnerForm.BorderStyle of
  bsSizeToolWin, bsToolWindow:
  begin
    H:=GetSystemMetrics(SM_CYSMSIZE);
    W:=GetSystemMetrics(SM_CXSMSIZE);
  end else
  begin
    H:=GetSystemMetrics(SM_CYSIZE);
    W:=GetSystemMetrics(SM_CXSIZE);
  end;
  end;
  if (Theme <> 0) then W:=H;
  r:=GetButtonRect(1,r3,Theme,0,W,H);
  r2.Left:=0;
  r2.Top:=0;
  r2.Right:=r.Right-r.Left;
  r2.Bottom:=r.Bottom-r.Top;
  DrAux.SetSize(r2.Right,r2.bottom);

  if (Theme <> 0) then
  begin
    DoForTheme;
    CloseThemeData(Theme);
  end else
  begin
    _XPStyle:=NO_THEME;
  end;
end;

Function TCaptionButtonArray.GetButtonRect(index : byte; rec : TRect; theme : cardinal; OffSet : integer; XS, YS: integer) : TRect;
var
  BW, BH, borderx, bordery : integer;
begin
  case OwnerForm.BorderStyle of bsSizeable, bsSizeToolWin:
  begin
    bordery:=GetSystemMetrics(SM_CYSIZEFRAME);
    borderx:=GetSystemMetrics(SM_CXSIZEFRAME);
  end;
  else
  begin
    bordery:=GetSystemMetrics(SM_CYFIXEDFRAME);
    borderx:=GetSystemMetrics(SM_CXFIXEDFRAME);
  end;
  end;
  if (theme <> 0) then
  bw:=XS-4
  else bw:=XS-2;
  bh:=YS-4;
  result:=bounds((rec.Right-rec.Left)-borderx-(2*index)-(bw*(index))-OffSet,bordery+2,bw,bh);
end;

Function TCaptionButtonArray.RemoveIcon(Bm : TBitmap; FillR : PRect = nil) : TBtnInfo;
var
  ymid, xmid, rmid, dif : integer;
  i : cardinal;
  Ant, this, fil : TRGB;
  rec : trect;
begin
  if (FillR = nil) then
  begin
    ymid:=bm.Height div 2;
    xmid:=bm.Width div 2;

    for i := ymid to bm.Height - 1 do
    begin
      TColor(ant):=bm.Canvas.Pixels[xmid,i-1];
      TColor(this):=bm.Canvas.Pixels[xmid,i];
      dif:=ant.r+ant.g+ant.b;
      dec(dif,this.r+this.g+this.b);
      if (abs(dif) > IconDif) then
      begin
        rec.Top:=i;
        result.IconColor:=TColor(bm.Canvas.Pixels[xmid,i+1]);
        break;
      end;
    end;

    for I := rec.Top+1 to bm.Height-1 do
    begin
      TColor(ant):=bm.Canvas.Pixels[xmid,i];
      TColor(this):=bm.Canvas.Pixels[xmid,i+1];
      dif:=ant.r+ant.g+ant.b;
      dec(dif,this.r+this.g+this.b);
      if (abs(dif) > IconDif) then
      begin
        rec.bottom:=i+2;
        break;
      end;
    end;

    rmid:=(rec.Top+rec.Bottom) div 2;

    for I := 3 to bm.width-1 do
    begin
      TColor(ant):=bm.Canvas.Pixels[i-1,rmid];
      TColor(this):=bm.Canvas.Pixels[i,rmid];
      dif:=ant.r+ant.g+ant.b;
      dec(dif,this.r+this.g+this.b);
      if (abs(dif) > IconDif) then
      begin
        rec.left:=i;
        fil:=TRGB(bm.canvas.pixels[i-1,rec.top]);
        break;
      end;
    end;

    for I := rec.Left+1 to bm.width-1 do
    begin
      TColor(ant):=bm.Canvas.Pixels[i,rmid];
      TColor(this):=bm.Canvas.Pixels[i+1,rmid];
      dif:=ant.r+ant.g+ant.b;
      dec(dif,this.r+this.g+this.b);
      if (abs(dif) > IconDif) then
      begin
        rec.right:=i+2;
        break;
      end;
    end;
  end;

  if (FillR = nil) then
  begin
    bm.Canvas.Brush.Color:=TColor(fil);
    bm.Canvas.FillRect(rec);
    result.Rect:=rec;
  end
  else
  begin
    bm.Canvas.Brush.Color:=bm.Canvas.Pixels[FillR^.Left-1,(FillR^.Top+FillR^.Bottom) div 2];
    Result.IconColor:=bm.Canvas.Pixels[FillR^.Left+2,(FillR^.Top+FillR^.Bottom) div 2];
    Result.Rect:=FillR^;
    bm.Canvas.FillRect(FillR^);
  end;

end;

procedure TCaptionButtonArray.DrawSingleButton(index: integer; DC, stat: Cardinal; fast : boolean = true);
var
  btn : TCaptionButton;
  aux : cardinal;
  r : TRect;
begin
  if (index > count-1) then exit;//nothing to do;
  btn:=Items[Index];
  if not(btn.Visible) then Exit;
  if (Fast) then
  begin
    if (btn.State = stat) then exit;
    if (_XPStyle = NO_THEME) then
    begin
      if (Stat > 4) then dec(stat,4);
      case stat of
        BT_HOT,BT_IHOT,BT_INORMAL: stat:=BT_NORMAL;
      end;
      aux:=btn.State;
      case aux of
        BT_HOT,BT_IHOT,BT_INORMAL: aux:=BT_NORMAL;
      end;
      if (stat = aux) then exit;
    end;
  end;
  if (_XPStyle <> NO_THEME) then
  begin
    if btn.OwnerDrawed then
    begin
      DrAux.Assign(Bitmaps[stat]);
      if Assigned(btn.OnDraw) then btn.OnDraw(btn,DrAux,stat,index);
      Transparentblt(DC,btn.Rect.Left,btn.Rect.Top,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,
      DrAux.Canvas.Handle,0,0,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,0);
    end else
    begin
      Transparentblt(DC,btn.Rect.Left,btn.Rect.Top,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,
      Bitmaps_[stat].Canvas.Handle,0,0,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,0);
    end;
  end else
  begin
    if (stat = BT_PUSHED) or (stat = BT_IPUSHED) then
    aux:=(DFCS_PUSHED or DFCS_BUTTONPUSH) else
    aux:=DFCS_BUTTONPUSH;
    DrawFrameControl(DrAux.Canvas.Handle,
    bounds(0,0,DrAux.Width,DrAux.Height),DFC_BUTTON,aux);
    if btn.OwnerDrawed then
    begin
      if Assigned(btn.OnDraw) then Btn.OnDraw(btn,DrAux,stat,index);
      bitblt(DC,btn.Rect.Left,btn.Rect.Top,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,
      DrAux.Canvas.Handle,0,0,srccopy);
    end else
    begin
      r.Top:=trunc(DrAux.Height*0.65);
      r.Bottom:=trunc(DrAux.Height*0.85);
      r.Left:=trunc(DrAux.Width*0.55);
      r.Right:=trunc(DrAux.Width*0.85);
      if (stat = BT_PUSHED) then
      begin
        inc(r.Top);
        inc(r.Bottom);
        inc(r.Left);
        inc(r.Right);
      end;
      if (stat = BT_IDISABLED) or (stat = BT_DISABLED) then
      begin
        inc(r.Right);
        inc(r.Bottom);
        DrAux.Canvas.Brush.Color:=clwhite;
        DrAux.Canvas.FillRect(r);
        dec(r.Right);
        dec(r.Bottom);
        DrAux.Canvas.Brush.Color:=clGrayText;
        DrAux.Canvas.FillRect(r);
      end else
      begin
        DrAux.Canvas.Brush.Color:=clbtntext;
        DrAux.Canvas.FillRect(r);
      end;
      bitblt(DC,btn.Rect.Left,btn.Rect.Top,
      btn.Rect.Right-btn.Rect.Left,
      btn.Rect.bottom-btn.Rect.top,
      DrAux.Canvas.Handle,0,0,srccopy);
    end;
  end;
  btn.State:=stat;
end;

//This is the component's WindowProc
procedure TCaptionButtonArray.WndProc(var msg : TMessage);
begin
  if (Lock <> 0) then if (Lock = msg.Msg) then exit;
  case msg.Msg of
    WM_NCPAINT, WM_NCACTIVATE, CM_TEXTCHANGED : ON_WM_NCPAINT(msg);
    WM_THEMECHANGED :
    begin
      ThemeChanged:=true;
      ParentWndProc(msg);
    end;
    WM_NCLBUTTONDOWN : ON_WM_NCLBUTTONDOWN(msg);
    WM_NCLBUTTONUP, WM_LBUTTONUP : ON_WM_NCLBUTTONUP(msg);
    WM_NCHITTEST : if (Pushed = -1) then ON_WM_NCHITTEST(msg);
    WM_MOUSEMOVE : if (Pushed <> -1) then ON_WM_NCHITTEST(msg);
    WM_NCRBUTTONDOWN : ON_WM_NCRBUTTONDOWN(msg);
    WM_NCRBUTTONUP, WM_RBUTTONUP : ON_WM_NCRBUTTONUP(msg);
    WM_TIMER : ON_WM_TIMER(msg);
    WM_NCMOUSELEAVE : ON_WM_NCMOUSELEAVE(msg);
    else ParentWndProc(msg);
  end;
  //Debug Begin
  //This is for debug only, to display on the form the messages that the
  //window receives. Requires unit UMessageStr
  (*if (msg.Msg <> WM_NCHITTEST) and
  (msg.Msg <> WM_MOUSEMOVE) and
  (msg.Msg <> WM_NCMOUSEMOVE)and
  (msg.Msg <> WM_SETCURSOR) {and
  (msg.Msg <> WM_ENTERIDLE)  }
  then
  begin
    mês.Add(mestostr(msg.Msg)+'       W = '+IntToHex(msg.WParam,8)+
    '       L = '+IntToHex(msg.LParam,8)+'       R = '+IntToHex(msg.Result,8));
    if mês.Count > 59 then mês.Delete(0);
    for I := 0 to mês.Count - 1 do
    begin
      OwnerForm.Canvas.TextOut(4,abs(OwnerForm.Canvas.Font.Height)*i,mês[i]+
      '                                                             ');
    end;
  end;  *)
  //Debug End;
  //OwnerForm.Canvas.TextOut(2,30,inttostr(Ntime));
end;

//Messages methods ->
procedure TCaptionButtonArray.ON_WM_NCPAINT(var msg: TMessage);
var
  OffSet : integer;
  r : TRect;
  i, aux, DC : cardinal;
  H, W : integer;
  pt : TPoint;
begin
  ParentWndProc(msg);
  OffSet:=0;
  H:=GetSystemMetrics(SM_CYSIZE);
  W:=GetSystemMetrics(SM_CXSIZE);
  if (H <> BtnH) or (W <> BtnW) then
  begin
    ThemeChanged:=true;
    BtnH:=H;
    BtnW:=W;
  end;
  DoThEvt:=ThemeChanged;
  if (ThemeChanged) then UpdateBitmaps;
  if (_XPStyle <> NO_THEME) then W:=H;

  GetWindowRect(OwnerForm.Handle,r);
  GetCursorPos(pt);
  dec(pt.X,OwnerForm.Left);
  dec(pt.Y,OwnerForm.Top);
  Selected:=-1;
  DC:=GetWindowDC(OwnerForm.Handle);
  for i := 0 to Count-1 do
  begin
    OffSet:=Offset+Items[i].OffSet;
    Items[i].Rect:=GetButtonRect(_ToBegin+i,r,Theme,OffSet,W,H);
    if PtInRect(Items[i].Rect,pt) then Selected:=i;
    Aux:=s4(sb((msg.Msg = WM_NCACTIVATE),(msg.WParam <> 0),(OwnerForm.Active)),0,BT_DISABLED);
    inc(Aux,s4(((Selected=Pushed)and(Pushed=integer(i))),BT_PUSHED,s4((Items[i].Enabled),
    s4((integer(i) = Selected),BT_HOT,BT_NORMAL),BT_DISABLED)));
    if Items[i].Visible then
    DrawSingleButton(i,DC,Aux,false);
  end;
  ReleaseDC(OwnerForm.Handle,DC);
  if DoThEvt and Assigned(_OnThemeChange) then
  begin
    _OnThemeChange(Self);
    DoThEvt:=false;
  end;
end;

procedure TCaptionButtonArray.ON_WM_NCHITTEST(var msg: TMessage);
var
  i, aux, DC : Cardinal;
  sel : integer;
  pt : TPoint;
begin
  if (msg.Msg = WM_NCHITTEST) then
  begin
    pt.X:=loword(msg.LParam);
    pt.Y:=hiword(msg.LParam);
  end else GetCursorPos(pt);
  dec(pt.x,OwnerForm.Left);
  dec(pt.Y,OwnerForm.Top);
  sel:=-1;
  for i := 0 to Count - 1 do
  begin
    if (PtInRect(Items[i].Rect,pt)) then sel:=i;
  end;

  if (sel = -1) or not(Items[sel].Visible) or (msg.Msg = WM_MOUSEMOVE) then ParentWndProc(msg) else
  begin
    msg.Result:=HTCUSTOMBUTTON;
  end;

  if (sel <> Selected) then
  begin
    if HintShow then HintWindow.ReleaseHandle;
    DC:=0;
    if (Selected <> -1) and (Items[Selected].Enabled) and (Items[selected].Visible) then
    begin
      DC:=GetWindowDC(OwnerForm.Handle);
      aux:=s4((OwnerForm.Active),0,BT_DISABLED);
      inc(aux,s4((Items[Selected].Enabled),BT_NORMAL,BT_DISABLED));
      DrawSingleButton(Selected,DC,aux);
    end;

    if (sel <> -1) and (Items[sel].Enabled) and (Items[sel].Visible) and
    ((Pushed = sel) or (Pushed = -1)) then
    begin
      if (DC = 0) then DC:=GetWindowDC(OwnerForm.Handle);
      aux:=s4((OwnerForm.Active),0,BT_DISABLED);
      inc(aux,s4((Pushed = sel),BT_PUSHED,s4((Items[sel].Enabled),BT_HOT,BT_DISABLED)));
      DrawSingleButton(sel,DC,aux);
    end;

    if TimerSet then
    begin
      KillTimer(OwnerForm.Handle,BTTIMERID);
      TimerSet:=false;
    end;
    if (sel <> -1) and (Items[sel].ShowHint) and (Items[sel].Enabled)
    and (Items[sel].Visible) then
    begin
      SetTimer(OwnerForm.Handle,BTTIMERID,_HintShowTime,nil);
      TimerSet:=true;
    end;

    Selected:=sel;
    if (DC <> 0) then ReleaseDC(OwnerForm.Handle,DC);
  end{else nothing to do};
  if (Selected = -1) and (HintShow) then HintWindow.ReleaseHandle;
end;

procedure TCaptionButtonArray.ON_WM_NCLBUTTONDOWN(var msg: TMessage);
var
  DC, aux : Cardinal;
begin
  if (Selected = -1) or not(Items[Selected].Visible) or not(Items[Selected].Enabled) then
  begin
    ParentWndProc(msg);
    exit;
  end;

  Pushed:=Selected;
  SetCapture(OwnerForm.Handle);
  aux:=s4((OwnerForm.Active),0,BT_DISABLED);
  inc(aux,BT_PUSHED);
  DC:=GetWindowDC(OwnerForm.Handle);
  DrawSingleButton(Pushed,DC,aux);
  ReleaseDC(OwnerForm.Handle,DC);
  msg.Result:=0;
end;

procedure TCaptionButtonArray.ON_WM_NCLBUTTONUP(var msg: TMessage);
var
  DC, aux : Cardinal;
  tmp : integer;
begin
  DC:=0;

  ParentWndProc(msg);
  if (Pushed <> -1) then ReleaseCapture;
  if (Selected = Pushed) and (Selected <> -1) then
  begin
    aux:=s4((OwnerForm.Active),0,BT_DISABLED);
    inc(aux,BT_HOT);
    DC:=GetWindowDC(OwnerForm.Handle);
    DrawSingleButton(pushed,DC,aux);
    if (Assigned(Items[Pushed].OnClick)) then
    begin
      tmp:=Pushed;
      Pushed:=-1;
      Items[tmp].OnClick(Items[tmp],tmp);
      Pushed:=tmp;
    end;
  end else
  if (Selected <> -1) then
  begin
    aux:=s4((OwnerForm.Active),0,BT_DISABLED);
    inc(aux,s4(Items[Selected].Enabled,BT_HOT,BT_DISABLED));
    if (DC = 0) then DC:=GetWindowDC(OwnerForm.Handle);
    DrawSingleButton(Selected,DC,aux);
  end;
  if (DC <> 0) then ReleaseDC(OwnerForm.Handle,DC);
  Pushed:=-1;
end;

procedure TCaptionButtonArray.ON_WM_NCRBUTTONDOWN(var msg: TMessage);
begin
  if (Selected <> -1) and (items[Selected].Enabled)
  and (Items[Selected].Visible) then
  begin
    RPushed:=Selected;
    SetCapture(OwnerForm.Handle);
    msg.Result:=0;
  end else if (Selected = -1) or not(Items[selected].Visible)
  then ParentWndProc(msg);
end;

procedure TCaptionButtonArray.ON_WM_NCRBUTTONUP(var msg: TMessage);
var
  DC, aux : Cardinal;
  pt : TPoint;
  did : boolean;
begin
  did:=false;
  if (RPushed <> -1) then ReleaseCapture;
  if (Selected = RPushed) and (Selected <> -1) then
  begin
    if (msg.Msg = WM_NCRBUTTONUP) then
    begin
      pt.X:=TSmallPoint(msg.LParam).x;
      pt.Y:=TSmallPoint(msg.LParam).y;
    end else
    begin
      GetCursorPos(pt);
    end;
    did:=true;
    if (Assigned(Items[RPushed].PopUpMenu)) then Items[RPushed].PopUpMenu.Popup(pt.X,pt.Y);
    msg.Result:=0;
  end else
  begin
    if (Selected <> -1) then
    begin
      aux:=s4((OwnerForm.Active),0,BT_DISABLED);
      inc(aux,s4(Items[Selected].Enabled,BT_HOT,BT_DISABLED));
      DC:=GetWindowDC(OwnerForm.Handle);
      DrawSingleButton(Selected,DC,aux);
      ReleaseDC(OwnerForm.Handle,DC);
    end;
  end;
  if ((Selected = -1) or (not Items[selected].Visible)) and not(did) then ParentWndProc(msg);
  RPushed:=-1;
end;

procedure TCaptionButtonArray.ON_WM_TIMER(var msg: TMessage);
var
  r : TRect;
  pt : TPoint;

begin
  if (Cardinal(msg.wParam) = BTTIMERID) and (Selected <> -1) then
  begin
    GetCursorPos(pt);
    r.Top:=pt.Y+20;
    r.Bottom:=r.Top+abs(HintWindow.Font.Height)+4;
    r.Left:=pt.X;
    r.Right:=r.Left+HintWindow.Canvas.TextWidth(Items[selected].Hint)+4;
    dec(pt.X,OwnerForm.Left);
    dec(pt.Y,OwnerForm.Top);
    if (PtInRect(Items[Selected].Rect,pt)) then
    begin
      HintWindow.ActivateHint(r,Items[selected].Hint);
      HintShow:=true;
      SetTimer(OwnerForm.Handle,HIDEHINTID,_HintHideTime,nil);
      HideSet:=True;
    end;
    msg.Result:=0;
  end else if (Cardinal(msg.WParam) = HIDEHINTID) then
  begin
    if HintShow then HintWindow.ReleaseHandle;
    if (HideSet) then
    begin
      KillTimer(OwnerForm.Handle,HIDEHINTID);
      HideSet:=false;
    end;
  end else ParentWndProc(msg);
  if (TimerSet) and (Cardinal(msg.WParam) = BTTIMERID) then
  begin
    KillTimer(OwnerForm.Handle,BTTIMERID);
    TimerSet:=false;
  end;
end;

procedure TCaptionButtonArray.ON_WM_NCMOUSELEAVE(var msg: TMessage);
var
  DC, aux : cardinal;
  pt : TPoint;
begin
  GetCursorPos(pt);
  dec(pt.X,OwnerForm.Left);
  dec(pt.Y,OwnerForm.Top);
  if (Selected <> -1) and (Pushed = -1) and (Items[Selected].Enabled)
  and not(PtInRect(Items[selected].Rect,pt)) then
  begin
    aux:=s4(OwnerForm.Active,0,BT_DISABLED);
    inc(aux,BT_NORMAL);
    DC:=GetWindowDC(OwnerForm.Handle);
    DrawSingleButton(Selected,DC,aux);
    ReleaseDC(OwnerForm.Handle,DC);
    if (TimerSet) then
    begin
      KillTimer(OwnerForm.Handle,BTTIMERID);
      TimerSet:=false;
    end;
    Selected:=-1;
  end;
  ParentWndProc(msg);
  if HintShow then HintWindow.ReleaseHandle;
end;

// Very boring write methods ->
Procedure TCaptionButtonArray.SetToBegin(AValue: Byte);
begin
  if (AValue = _Tobegin) then exit;
  _ToBegin:=AValue;
  Perform(WM_NCPAINT,1,0);
end;

procedure TCaptionButton.SetOffset(AValue: Integer);
begin
  if (AValue = _OffSet) then exit;
  _OffSet:=AValue;
  TCaptionButtonArray(Collection).Perform(WM_NCPAINT,1,0);
end;

procedure TCaptionButton.SetEnabled(AValue: Boolean);
begin
  if (AValue = _Enabled) then exit;
  _Enabled:=AValue;
  TCaptionButtonArray(Collection).Perform(WM_NCPAINT,1,0);
end;

procedure TCaptionButton.SetVisible(AValue: Boolean);
begin
  if (AValue = _Visible) then exit;
  _Visible:=AValue;
  TCaptionButtonArray(Collection).Perform(WM_NCPAINT,1,0);
end;

//These are the initialization and finalization section required for
//the debug section of the WndProc method. For debug only.
{initialization
  mês:=TStringList.Create;
finalization
  mês.Destroy;  }
end.

Espero que seja útil.

Abraços.

Editado Maio 2, 2007 por Thales Pontes Martins

[Guest Visitante]

Thales, não consegui acessar o link com o exemplo, é possível enviar para mim por e-mail?

thi_nazireu@yahoo.com.br

muito obrigado!

[Thales Pontes Martins]

Aviso que os links do 1º post não estão funcionando porque minha conta no servidor foi cancelada por falta de pagamento. Aqui tem outro link para o exe com código fonte na conta do amigo Thiago -> Caption Buttons.rar

Abraços.

Editado Maio 2, 2007 por Thales Pontes Martins