Виртуальная библиотека Delphi

    { 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;

  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 := 'OOOH! Doughnuts!';

  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.Button1Click(Sender: TObject);

begin

  Close;

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;