Создание окна в виде бублика

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: 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.

{/codecitation}

Добавить комментарий