Как изменить шрифт и выравнивание в заголовке формы?
Как изменить шрифт и выравнивание в заголовке формы?
Note: The formDeactivate never gets called so when the form isn't active, sometimes the FormPaint isn't called. If anything causes the form to be repainted while in inactive, it draws correctly.
unitUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var
LabelHeight, LabelWidth, LabelTop: Integer;
caption_height, border3d_y, button_width, border_thickness: Integer;
MyCanvas: TCanvas;
CaptionBarRect: TRect;
begin
CaptionBarRect := Rect(0, 0, 0, 0);
MyCanvas := TCanvas.Create;
MyCanvas.Handle := GetWindowDC(Form1.Handle);
border3d_y := GetSystemMetrics(SM_CYEDGE);
button_width := GetSystemMetrics(SM_CXSIZE);
border_thickness := GetSystemMetrics(SM_CYSIZEFRAME);
caption_height := GetSystemMetrics(SM_CYCAPTION);
LabelWidth := Form1.Canvas.TextWidth(Form1.Caption);
LabelHeight := Form1.Canvas.TextHeight(Form1.Caption);
LabelTop := LabelHeight - (caption_height div 2);
CaptionBarRect.Left := border_thickness + border3d_y + button_width;
CaptionBarRect.Right := Form1.Width - (border_thickness + border3d_y)
- (button_width * 4);
CaptionBarRect.Top := border_thickness + border3d_y;
CaptionBarRect.Bottom := caption_height;
if Form1.Active then
MyCanvas.Brush.Color := clActiveCaption
else
MyCanvas.Brush.Color := clInActiveCaption;
MyCanvas.Brush.Style := bsSolid;
MyCanvas.FillRect(CaptionBarRect);
MyCanvas.Brush.Style := bsClear;
MyCanvas.Font.Color := clCaptionText;
MyCanvas.Font.Name := 'MS Sans Serif';
MyCanvas.Font.Style := MyCanvas.Font.Style + [fsBold];
DrawText(MyCanvas.Handle, PChar(' ' + Form1.Caption), Length(Form1.Caption) + 1,
CaptionBarRect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
MyCanvas.Free;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Form1.Paint;
end;
procedure TForm1.FormDeactivate(Sender: TObject);
begin
Form1.Paint;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Form1.Paint;
end;
end.
{ ... }
type
TForm1 = class(TForm)
private
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
ACanvas: TCanvas;
begin
inherited;
ACanvas := TCanvas.Create;
try
ACanvas.Handle := GetWindowDC(Form1.Handle);
with ACanvas do
begin
Brush.Color := clActiveCaption;
Font.Name := 'Tahoma';
Font.Size := 8;
Font.Color := clred;
Font.Style := [fsItalic, fsBold];
TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,
' Some Text');
end;
finally
ReleaseDC(Form1.Handle, ACanvas.Handle);
ACanvas.Free;
end;
end;