[转]自定义标题栏字体

unit MainFrm;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
procedure WMPaint(var Msg : TWMPaint); message WM_PAINT;
procedure WMResize(var MSG: TWMSize); message WM_SIZE;
procedure WMNCActivate(var Msg : TWMActivate); message WM_ACTIVATE;
procedure WMMove(var Msg: TWMMove); message WM_MOVE;
public
{ Public declarations }
end;

var
Form1: TForm1;
hHeader: hDC;
Font1, Font2, Font3: hFont;
FrameH, FrameW, SmIconW, CaptionH, BorderH: integer;
DocumentName: string;

implementation

{$R *.dfm}

procedure DrawCaption(Form: TForm);
var HeadRect: TRect;
Size: TSize;
tmp: string;
begin
//Get header coordinates
HeadRect.Top:= FrameH;
HeadRect.Bottom:= HeadRect.Top+ CaptionH- BorderH;
HeadRect.Left:= FrameW+ SmIconW+ 5;
HeadRect.Right:= HeadRect.Left+ FrameW- 80;
SetBKMode(hHeader, TRANSPARENT);

//Draw each word separately - Note
SetTextColor(hHeader, clWhite);
SelectObject(hHeader, Font1);
tmp:= 'Note';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
//Now reduce the size of rectangle so the next word will not overlay
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

//Writer
SelectObject(hHeader, Font2);
Tmp:= 'Writer';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

//3G
SetTextColor(hHeader, clLtGray);
SelectObject(hHeader, Font3);
tmp:= ' 3G';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

// - [Untitled Document]
SetTextColor(hHeader, clWhite);
SelectObject(hHeader, Font2);
if DocumentName= '' then
tmp:= '' else
tmp:= ' - '+DocumentName;
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
end;

procedure DrawDimCaption(Form: TForm);
var HeadRect: TRect;
Size: TSize;
tmp: string;
begin
//Get header coordinates
HeadRect.Top:= FrameH;
HeadRect.Bottom:= HeadRect.Top+ CaptionH- BorderH;
HeadRect.Left:= FrameW+ SmIconW+ 5;
HeadRect.Right:= HeadRect.Left+ FrameW- 80;
SetBKMode(hHeader, TRANSPARENT);

//Draw each word separately - Note
SetTextColor(hHeader, clLtGray);
SelectObject(hHeader, Font1);
tmp:= 'Note';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
//Now reduce the size of rectangle so the next word will not overlay
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

//Writer
SetTextColor(hHeader, clLtGray);
SelectObject(hHeader, Font2);
Tmp:= 'Writer';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

//3G
SetTextColor(hHeader, clLtGray);
SelectObject(hHeader, Font3);
tmp:= ' 3G';
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
GetTextExtentPoint(hHeader, PChar(tmp), length(tmp), Size);
HeadRect.Left:= HeadRect.Left+ Size.cx;

// - [Untitled Document]
SetTextColor(hHeader, clLtGray);
SelectObject(hHeader, Font2);
if DocumentName= '' then
tmp:= '' else
tmp:= ' - '+DocumentName;
drawtext(hHeader, PChar(tmp), -1, HeadRect, DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
end;

procedure TForm1.WMNCActivate(var Msg: TWMActivate);
begin
inherited;
if boolean(Msg.Active) then
DrawCaption(self) else
DrawDimCaption(self);
end;

procedure TForm1.WMPaint(var Msg: TWMPaint);
begin
inherited;
DrawCaption(self);
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
inherited;
DrawCaption(self);
end;

procedure TForm1.WMResize(var MSG: TWMSize);
begin
inherited;
DrawCaption(self);
end;

procedure TForm1.WMMove(var Msg: TWMMove);
begin
inherited;
DrawCaption(self);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//Put this here to improve speed
FrameH:= GetSystemMetrics(SM_CYFRAME);
FrameW:= GetSystemMetrics(SM_CXFRAME);
SmIconW:= GetSystemMetrics(SM_CXSMICON);
CaptionH:= GetSystemMetrics(SM_CYCAPTION);
BorderH:= GetSystemMetrics(SM_CYBORDER);
Font1:= CreateFont(15, 0, 0, 0, FW_BOLD, LongWord(false), LongWord(false), LongWord(false), DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH,
'Arial');
Font2:= CreateFont(14, 0, 0, 0, FW_NORMAL, LongWord(false), LongWord(false), LongWord(false), DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH,
'Arial');
Font3:= CreateFont(15, 0, 0, 0, FW_BOLD, LongWord(false), LongWord(false), LongWord(false), DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH,
'Arial');
//Initialize the header pointer
hHeader:= GetWindowDC(self.Handle);
//Kill the current form caption so it doesn't interfere
self.Caption:= '';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
DocumentName:= 'Cool';
DrawCaption(self);
end;

end.