unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, 
Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

  private
    { Private declarations }

    TBRect: TRect;   // Caption Bar Button Rectangle
    CBBtnFont: TFont;   // Caption Bar Button Font
    procedure DrawCaptionBtn(uEdge: UINT);
    // 當在標題欄上按下鼠標左按鈕時進入該過程
procedure WMNcLButtonDown(var m: TMessage); 
message WM_NCLBUTTONDOWN;
    // 當在標題欄上放開鼠標左按鈕時進入該過程
procedure WMNcLButtonUp(var m: TMessage); 
message WM_NCLBUTTONUP;
    // 當在標題欄上移動鼠標時進入該過程
procedure WMNcMouseMove(var m: TMessage); 
message WM_NCMOUSEMOVE;
    // 當在標題欄上雙擊鼠標左銨鈕時進入該過程
procedure WMNcLButtonDBLClk
(var m: TMessage); message WM_NCLBUTTONDBLCLK;
    // 當在標題欄上按下鼠標右按鈕時進入該過程
procedure WMNcRButtonDown(var m: TMessage); 
message WM_NCRBUTTONDOWN;
    // 當畫標題欄時進入該過程
procedure WMNcPaint(var m: TMessage); 
message WM_NCPAINT;
    // 當標題欄在激活與非激活之間切換時進入該過程
procedure WMNcActivate(var m: TMessage); 
message WM_NCACTIVATE;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DrawCaptionBtn(uEdge: UINT);
var
   hCaptionDC: HDC; // 標題條Device Context
   hOldFont: HFONT; // 原來的字體
   r: TRect;
begin
     hCaptionDC := GetWindowDC(Self.Handle);
 // 注意不能用GetDC,那樣的話，將得不到標題欄
 // 的設備上下文
     //畫按鈕的樣子，如果uEdge=EDGE_RAIS，
則畫出的樣子為凸起；如果
//uEdge=EDGE_SUNKEN，則畫出的樣子為凹下。
     DrawEdge(hCaptionDC, TBRect, uEdge, 
BF_RECT or BF_MIDDLE or
            BF_SOFT); 

     //設置標題欄的設備上下文為透明狀態
     SetBkMode(hCaptionDC, TRANSPARENT);

     //設置標題欄設備上下文的字體
     hOldFont:= SelectObject(hCaptionDC, CBBtnFont.Handle);

     //畫按鈕
     if uEdge = EDGE_RAISED then
        DrawText(hCaptionDC, 'Caption Bar Button', 
18, TBRect, DT_CENTER)
     else begin
        r := TBRect;
        OffsetRect(r, 1, 1); 
        DrawText(hCaptionDC, 'Caption Bar Button', 18, r, DT_CENTER);
     end;

     //還原為原來的字體
     SelectObject(hCaptionDC, hOldFont);
end;

procedure TForm1.WMNcActivate(var m: TMessage);
begin
     inherited;
     DrawCaptionBtn(EDGE_RAISED);
end;


procedure TForm1.WMNcPaint(var m: TMessage);
begin
     inherited;
     DrawCaptionBtn(EDGE_RAISED);
end;


procedure TForm1.WMNcLButtonDBLClk(var m: TMessage);
var
   p: TPoint;
begin
     p.x := LOWORD(m.lParam) - Self.Left;
     p.y := HIWORD(m.lParam) - Self.Top;
     if not PtInRect(TBRect, p) then // 如果不在按鈕區域內
        inherited;  // 執行默認的操作
end;

procedure TForm1.WMNcMouseMove(var m: TMessage);
var
   p: TPoint;
begin
     p.x := LOWORD(m.lParam) - Self.Left;
     p.y := HIWORD(m.lParam) - Self.Top;
     if not PtInRect(TBRect, p) then // 如果不在按鈕區域
        DrawCaptionBtn(EDGE_RAISED)
     else
        inherited; // 執行默認的操作
end;


procedure TForm1.WMNcLButtonDown(var m: TMessage);
var
   p: TPoint;
begin
     p.x := LOWORD(m.lParam) - Self.Left;
     p.y := HIWORD(m.lParam) - Self.Top;
     if PtInRect(TBRect, p) then  // 如果按在了按鈕區域
     begin
        Self.BringToFront;
        DrawCaptionBtn(EDGE_SUNKEN);
     end
     else
        inherited; // 執行默認的操作
end;


procedure TForm1.WMNcLButtonUp(var m: TMessage);
var
   p: TPoint;
begin
     p.x := LOWORD(m.lParam) - Self.Left;
     p.y := HIWORD(m.lParam) - Self.Top;
     if PtInRect(TBRect, p) then // 
如果在標題欄按鈕區域釋放鼠標
     begin
        DrawCaptionBtn(EDGE_RAISED);
     end
     else
        inherited; // 執行默認的操作
end;


procedure TForm1.WMNcRButtonDown(var m: TMessage);
var
   p: TPoint;
begin
     p.x := LOWORD(m.lParam) - Self.Left;
     p.y := HIWORD(m.lParam) - Self.Top;
     if not PtInRect(TBRect, p) then // 如果不在標題欄按鈕區域
        inherited;  // 執行默認的操作
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
     // 這個大小大家可以得用GetSystemMetrics
函數來進行更精確的計算。這里
     // 只是用來示例
     with TBRect do
     begin
          left := 100;
          top  := 6;
          right := 450;
          bottom := 20;
     end;

     // 標題欄按鈕字體。
     CBBtnFont:= TFont.Create;
     with CBBtnFont do
     begin
          Name := '宋體';
          Size := 9;
          Color := clRed;
     end;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
     CBBtnFont.Free;
end;

end.