标题栏上画按钮代码示例

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

CBBtnRect: 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;

{ Private declarations }

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, CBBtnRect, 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, CBBtnRect, DT_CENTER)

else

begin

r := CBBtnRect;

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(CBBtnRect, 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(CBBtnRect, 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(CBBtnRect, 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(CBBtnRect, 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(CBBtnRect, p) then // 如果不在标题栏按钮区域

inherited; // 执行默认的操作

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

// 这个大小大家可以得用GetSystemMetrics函数来进行更精确的计算。这里

// 只是用来示例

with CBBtnRect do

begin

left := 100;

top := 6;

right := 450;

bottom := 20;

end;

// 标题栏按钮字体。

CBBtnFont:= TFont.Create;

with CBBtnFont do

begin

Name := '宋体';

Size := 9;

Color := clBlue ;

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

CBBtnFont.Free;

end;

end.