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

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

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.

{/codecitation}

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