Окно в виде кольца с изогнутой заголовочной полосой

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    rTitleBar : THandle;
    Center : TPoint;
    CapY : Integer;
    Circum : Double;
    SB1 : TSpeedButton;
    RL, RR : Double;
    procedure TitleBar(Act : Boolean);
    procedure WMNCHITTEST(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE); message WM_NCACTIVATE;
    procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
  public
  { Public declarations }
end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

const
  TitlColors : array[Boolean] of TColor = (clInactiveCaption, clActiveCaption);
  TxtColors : array[Boolean] of TColor = (clInactiveCaptionText, clCaptionText);

procedure TForm1.FormCreate(Sender: TObject);
var
  rTemp, rTemp2 : THandle;
  Vertices : array[0..2] of TPoint;
  X, Y : INteger;
begin
  Caption := 'Delphi World is great!';
  BorderStyle := bsNone; {required}
  if Width > Height then
    Width := Height
  else
    Height := Width; {harder to calc if width <> height}
  Center := Point(Width div 2, Height div 2);
  CapY := GetSystemMetrics(SM_CYCAPTION)+8;
  rTemp := CreateEllipticRgn(0, 0, Width, Height);
  rTemp2 := CreateEllipticRgn((Width div 4), (Height div 4),
  3*(Width div 4), 3*(Height div 4));
  CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
  SetWindowRgn(Handle, rTemp, True);
  DeleteObject(rTemp2);
  rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
  rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
  Vertices[0] := Point(0,0);
  Vertices[1] := Point(Width, 0);
  Vertices[2] := Point(Width div 2, Height div 2);
  rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
  CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
  DeleteObject(rTemp);
  RL := ArcTan(Width / Height);
  RR := -RL + (22 / Center.X);
  X := Center.X-Round((Center.X-1-(CapY div 2))*Sin(RR));
  Y := Center.Y-Round((Center.Y-1-(CapY div 2))*Cos(RR));
  SB1 := TSpeedButton.Create(Self);
  with SB1 do
  begin
    Parent := Self;
    Left := X;
    Top := Y;
    Width := 14;
    Height := 14;
    OnClick := Button1Click;
    Caption := 'X';
    Font.Style := [fsBold];
  end;
end;

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
begin
  inherited;
  with Msg do
    with ScreenToClient(Point(XPos,YPos)) do
      if PtInRegion(rTitleBar, X, Y) and
      (not PtInRect(SB1.BoundsRect, Point(X,Y))) then
        Result := htCaption;
end;

procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
begin
  inherited;
  TitleBar(Msg.Active);
end;

procedure TForm1.WMSetText(var Msg: TWMSetText);
begin
  inherited;
  TitleBar(Active);
end;

procedure TForm1.TitleBar(Act: Boolean);
var
  TF : TLogFont;
  R : Double;
  N, X, Y : Integer;
begin
  if Center.X = 0 then
    Exit;
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := TitlColors[Act];
    PaintRgn(Handle, rTitleBar);
    R := RL;
    Brush.Color := TitlColors[Act];
    Font.name := 'Arial';
    Font.Size := 12;
    Font.Color := TxtColors[Act];
    Font.Style := [fsBold];
    GetObject(Font.Handle, SizeOf(TLogFont), @TF);
    for N := 1 to Length(Caption) do
    begin
      X := Center.X-Round((Center.X-6)*Sin(R));
      Y := Center.Y-Round((Center.Y-6)*Cos(R));
      TF.lfEscapement := Round(R * 1800 / pi);
      Font.Handle := CreateFontIndirect(TF);
      TextOut(X, Y, Caption[N]);
      R := R - (((TextWidth(Caption[N]))+2) / Center.X);
      if R < RR then
        Break;
    end;
    Font.name := 'MS Sans Serif';
    Font.Size := 8;
    Font.Color := clWindowText;
    Font.Style := [];
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  with Canvas do
  begin
    Pen.Color := clBlack;
    Brush.Style := bsClear;
    Pen.Width := 1;
    Pen.Color := clWhite;
    Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
    Arc((Width div 4)-1, (Height div 4)-1,
    3*(Width div 4)+1, 3*(Height div 4)+1, 0, Height, Width, 0);
    Pen.Color := clBlack;
    Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
    Arc((Width div 4)-1, (Height div 4)-1,
    3*(Width div 4)+1, 3*(Height div 4)+1, Width, 0, 0, Height);
    TitleBar(Active);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

end.