Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

Видеокурс программиста и крэкера 5D 2O17
(актуальность: июль 2O17)
Свежие инструменты, новые видеоуроки!

  • 400+ видеоуроков
  • 800 инструментов
  • 100+ свежих книг и статей

УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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


 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.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS