... 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure WMNCPAINT(var msg: TMessage); message WM_NCPAINT; 
    procedure WMNCACTIVATE(var msg: TMessage); message WM_NCACTIVATE; 
    procedure WMSyscolor(var msg: TMessage); message WM_SysColorChange; 
    procedure PaintCaption(s: string); 
    procedure vorbereitung; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var 
  ncm: tagNONCLIENTMETRICSA; 
  i, b: integer; 
  Txt: string; 
  rct: TRect; 
  sz: TSize; 
  HF: HFont; 
  DC: HDC; 
 
procedure TForm1.vorbereitung; 
begin 
  systemparametersinfo(SPI_GETNONCLIENTMETRICS, 0, @ncm, 0); 
  HF := createFontindirect(ncm.lfCaptionFont); 
  Selectobject(DC, HF); 
  SetTextColor(DC, getsyscolor(COLOR_CAPTIONTEXT)); 
  SetBkMode(DC, TRANSPARENT); 
  b := GetSystemMetrics(SM_CXSIZE) * 3 + 4; 
  rct.Left := trunc(GetSystemMetrics(SM_CXSIZE) * 1.7); 
  rct.Top := GetSystemMetrics(SM_CYEDGE); 
  rct.Bottom := GetSystemMetrics(SM_CYCAPTION) + 
    GetSystemMetrics(SM_CYEDGE) + GetSystemMetrics(SM_CYBORDER); 
  GetTextExtentPoint32A(DC, PChar(Txt), length(Txt), sz); 
  i := b + rct.left; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  DC := GetWindowDC(Handle); 
  Txt := Caption; 
  Caption := ''; 
  ncm.cbSize := sizeof(ncm); 
  vorbereitung; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  DeleteObject(HF); 
  DeleteDC(DC); 
end; 
 
procedure TForm1.PaintCaption(s: string); 
begin 
  rct.Right := width - b; 
  if width - i < sz.cx then s := '...'; 
  DrawText(DC, PChar(s), -1, rct, DT_CENTER or DT_VCENTER 
    or DT_SINGLELINE); 
end; 
 
procedure TForm1.WMNCPAINT(var msg: TMessage); 
begin 
  inherited; 
  PaintCaption(Txt); 
end; 
 
procedure TForm1.WMNCACTIVATE(var msg: TMessage); 
begin 
  inherited; 
  PaintCaption(Txt); 
end; 
 
procedure TForm1.WMSyscolor(var msg: TMessage); 
begin 
  inherited; 
  vorbereitung; 
  PaintCaption(Txt); 
end; 

// ----------------------------------------------------------------

uses UxTheme; 
 
procedure TForm2.FormActivate(Sender: TObject); 
begin 
  SetWindowTheme(Handle, '', ''); 
end; 
 
var 
  ncm: TNonClientMetricsW; 
  i: integer; 
  Txt: string; 
  rct: TRect; 
  sz: TSize; 
  HF: HFont; 
  DC: HDC; 
 
procedure TForm2.FormDestroy(Sender: TObject); 
begin 
  DeleteObject(HF); 
  DeleteDC(DC); 
end; 
 
procedure TForm2.PaintCaption(s: string); 
begin 
  if width - i < sz.cx then 
    s := '...'; 
  DrawText(DC, PChar(s), -1, rct, DT_CENTER or DT_VCENTER or DT_SINGLELINE); 
end; 
 
procedure TForm2.WMNCPAINT(var msg: TMessage); 
begin 
  inherited; 
  PaintCaption(Txt); 
end; 
 
procedure TForm2.WMNCACTIVATE(var msg: TMessage); 
begin 
  inherited; 
  PaintCaption(Txt); 
end; 
 
procedure TForm2.WMSyscolor(var msg: TMessage); 
begin 
  inherited; 
  vorbereitung; 
  PaintCaption(Txt); 
end; 
 
procedure TForm2.vorbereitung; 
begin 
  systemparametersinfo(SPI_GETNONCLIENTMETRICS, 0, @ncm, 0); 
  HF := createFontindirectW(ncm.lfCaptionFont); 
  Selectobject(DC, HF); 
  SetTextColor(DC, getsyscolor(COLOR_CAPTIONTEXT)); 
  SetBkMode(DC, TRANSPARENT); 
  GetTextExtentPoint32A(DC, AnsiString(Txt), length(Txt), sz); 
  rct.left := (Clientwidth - sz.cx) div 2; 
  rct.right := rct.left + sz.cx; 
  rct.Top := (width - Clientwidth) div 2; 
  rct.Bottom := rct.Top + GetSystemMetrics(SM_CYCAPTION); 
end; 
 
procedure TForm2.FormCreate(Sender: TObject); 
begin 
  DC := GetWindowDC(Handle); 
  Txt := Caption; 
  Caption := ''; 
  ncm.cbSize := sizeof(ncm); 
  vorbereitung; 
end;