Jump to content
Fórum Script Brasil
  • 0

Botões Extras Na Barra De Título


Thales Pontes Martins
 Share

Question

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.
  [email protected]

* 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.

Edited by Thales Pontes Martins
Link to comment
Share on other sites

2 answers to this question

Recommended Posts

  • 0

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.

Edited by Thales Pontes Martins
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

 Share



  • Forum Statistics

    • Total Topics
      151k
    • Total Posts
      649.1k
×
×
  • Create New...