Ver Mensaje Individual
  #6  
Antiguo 30-01-2006
Avatar de roman
roman roman is offline
Moderador
 
Registrado: may 2003
Ubicación: Ciudad de México
Posts: 20.269
Reputación: 10
roman Es un diamante en brutoroman Es un diamante en brutoroman Es un diamante en bruto
Ahora que, si insisten, aquí está lo básico para empezar:

Código Delphi [-]
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    LinkCaption: String;

    (*
      Windows pinta el título en cualquiera de estos dos mensajes, así
      que hay que interceptarlos para dibujar el título nosotros mismos
    *)
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
    procedure WMNCActivate(var Msg: TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;

  public
    (* Método para dibujar el título *)
    procedure PaintCaption;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  LinkCaption := 'Enviar sugerencia';
end;

procedure TForm1.WMNCActivate(var Msg: TWMNCActivate);
begin
  inherited;
  PaintCaption; // Pintar el título
end;

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
begin
  inherited;
  PaintCaption; // Pintar el título
end;

procedure TForm1.PaintCaption;
var
  ncCanvas: TCanvas;
  cxSmIcon: Integer;
  cxSizeFrame: Integer;
  cySizeFrame: Integer;
  cyCaption: Integer;
  cxText: Integer;
  cyText: Integer;

begin
  ncCanvas := TCanvas.Create;
  try
    { Obtener un canvas que incluya el área no-cliente }
    ncCanvas.Handle := GetWindowDC(Handle);
    with ncCanvas do
    begin
      { Usar fondo transparente }
      Brush.Style := bsClear;

      { Fuente del título }
      if Windows.GetForegroundWindow = Self.Handle
        then Font.Color := clCaptionText
        else Font.Color := clInactiveCaptionText;

      Font.Style := Font.Style + [fsBold, fsUnderline];

      { Medidas para colocar el título }
      cxSmIcon := GetSystemMetrics(SM_CXSMICON);
      cxSizeFrame := GetSystemMetrics(SM_CXSIZEFRAME);
      cySizeFrame := GetSystemMetrics(SM_CYSIZEFRAME);
      cyCaption := GetSystemMetrics(SM_CYCAPTION);
      cxText := TextWidth(LinkCaption);
      cyText := TextHeight(LinkCaption);

      { Pintar el título }
      TextOut(
        ClientWidth - (cxSizeFrame + 3*cxSmIcon + cxText),
        cySizeFrame + ((cyCaption - cyText) div 2) - 1,
        LinkCaption);
    end;
  finally
    ReleaseDC(Handle, ncCanvas.Handle);
    ncCanvas.Free;
  end;
end;

procedure TForm1.WMSetCursor(var Msg: TWMSetCursor);
var
  ncCanvas: TCanvas;
  cxSmIcon: Integer;
  cxSizeFrame: Integer;
  cxText: Integer;
  htPoint: TPoint;

begin
  inherited;

  if Msg.HitTest = HTCAPTION then
  begin
    htPoint := ScreenToClient(Mouse.CursorPos);

    ncCanvas := TCanvas.Create;
    try
      { Obtener un canvas que incluya el área no-cliente }
      ncCanvas.Handle := GetWindowDC(Handle);

      with ncCanvas do
      begin
        Font.Style := Font.Style + [fsBold, fsUnderline];

        cxSmIcon := GetSystemMetrics(SM_CXSMICON);
        cxSizeFrame := GetSystemMetrics(SM_CXSIZEFRAME);
        cxText := TextWidth(LinkCaption);
      end;

      if (htPoint.X >= ClientWidth - (2*cxSizeFrame + 3*cxSmIcon + cxText)) then
      begin
        SetCursor(Screen.Cursors[crHandPoint]);

        if Msg.MouseMsg = WM_LBUTTONDOWN then
          ShowMessage('Enviando comentario');
      end;
    finally
      ncCanvas.Free;
    end;
  end
  else
    Screen.Cursor := crDefault;
end;

end.

Está muy sucio y hay que refinar muchas cosas pero más o menos funciona. Se basa en un formulario con borde normal y sus tres botones que corresponden al 3 que aparece como factor en las fórmulas de arriba.

Aquí no estamos añadiendo un botón sino literalmente añadiendo una "url" en la parte derecha de la barra de título.

// Saludos
Responder Con Cita