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

for I:= 0 to ControlCount -1 do

with Controls[I] do begin

Rgn:= CreateRectRgn(ClientX + Left, ClientY + Top, ClientX + Left +

Width, ClientY + Top + Height);

CombineRgn(FullRgn, FullRgn, Rgn, rgn_Or);

end;

// устанавливаем новый регион окна

SetWindowRgn(Handle, FullRgn, True);

end;

end.

А как Вам понравится эта форма ?

unit rgnu;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Buttons, Menus;

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

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.

GetShortPathName()

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.

Пример.

unit Main;

interface

uses

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

type

TForm1 = class(TForm)

procedure FormResize(Sender: TObject);

private

CaptionBtn : TRect;

procedure DrawCaptButton;

procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;

procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;

procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;

procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

const

htCaptionBtn = htSizeLast + 1;

{$R *.DFM}

procedure TForm1.DrawCaptButton;

var

xFrame, yFrame, xSize, ySize : Integer;

R : TRect;

begin

//Dimensions of Sizeable Frame

xFrame := GetSystemMetrics(SM_CXFRAME);

yFrame := GetSystemMetrics(SM_CYFRAME);

//Dimensions of Caption Buttons

xSize := GetSystemMetrics(SM_CXSIZE);

ySize := GetSystemMetrics(SM_CYSIZE);

//Define the placement of the new caption button

CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,

yFrame + 2, xSize - 2, ySize - 4);

//Get the handle to canvas using Form's device context

Canvas.Handle := GetWindowDC(Self.Handle);

Canvas.Font.Name := 'Symbol';

Canvas.Font.Color := clBlue;

Canvas.Font.Style := [fsBold];

Canvas.Pen.Color := clYellow;

Canvas.Brush.Color := clBtnFace;

try

DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);

//Define a smaller drawing rectangle within the button

R := Bounds(Width - xFrame - 4 * xSize + 2,

yFrame + 3, xSize - 6, ySize - 7);

with CaptionBtn do

Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');

finally

ReleaseDC(Self.Handle, Canvas.Handle);

Canvas.Handle := 0;

end;

end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMSetText(var Msg : TWMSetText);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);

begin

inherited;

with Msg do

if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then

Result := htCaptionBtn;

end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);