Delphi World - Окно в виде кольца с изогнутой заголовочной полосой
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Окно в виде кольца с изогнутой заголовочной полосой


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.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования