Автор: Danillo
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание Окна ВВиде Бублика

Зависимости: нет
Автор:       Danillo, dve2@inbox.ru
Copyright:   я
Дата:        16 марта 2003 г.
***************************************************** }

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormPaint(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;
  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 := 'Oy?ei iaiaei!!!';
  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) + 10;
  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;
  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;

end.