unit ArcUnit;
{   Этот пример демонстрирует, как вывести надпись с непрямой базовой линией.
    Идея заключается в том, что для каждой буквы рассчитывается свой угол поворота,
    зависящий от её положения. В данном случае базовая линия представляет собой дугу
    окружности с заданным радиусом. Начальная точка этой дуги задаётся углом её
    радиус-вектора с осью Х, конечная определяется длиной надписи. Комментировать в этом
    примере особенно нечего, достаточно справки по CreateFontIndirect и знания
    элементарной геометрии.

    Автор: Григорьев Антон (grigorievab@mail.ru), Черноголовка, 1999
    Специально для Королевства Delphi (http://delphi.vitpc.com)                     }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    BtnFont: TButton;
    FontDialog: TFontDialog;
    GroupBox1: TGroupBox;
    EditAngle: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    EditText: TEdit;
    Label3: TLabel;
    EditR: TEdit;
    BtnApply: TButton;
    procedure FormPaint(Sender: TObject);
    procedure BtnFontClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure BtnApplyClick(Sender: TObject);
   private
    S:string;
    BegAngle,Rad:Integer;
    X0,Y0:Integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
 var Angle:Double;
     L,CL,W,I,X,Y:Integer;
     TAngle:Integer;
     LF:TLogFont;
     OldFont,NewFont:HFont;
  begin
   with LF,FontDialog.Font do
    begin
     lfHeight:=Height;
     lfWidth:=0;
     lfEscapement:=0;
     lfOrientation:=0;
     if fsBold in Style then
      lfWeight:=FW_Bold
     else
      lfWeight:=FW_Normal;
     lfItalic:=Byte(fsItalic in Style);
     lfUnderline:=Byte(fsUnderline in Style);
     lfStrikeOut:=Byte(fsStrikeOut in Style);
     lfCharSet:=Byte(CharSet);
     lfOutPrecision:=Out_Default_Precis;
     lfClipPrecision:=Clip_Default_Precis;
     lfQuality:=Default_Quality;
     case Pitch of
      fpVariable:lfPitchAndFamily:=Variable_Pitch;
      fpFixed:lfPitchAndFamily:=Fixed_Pitch
     else
      lfPitchAndFamily:=Default_Pitch
     end;
     StrPCopy(lfFaceName,Name)
    end;
   with Canvas do
    begin
     L:=Round(2*Pi*Rad);
     SetTextAlign(Canvas.Handle,TA_Bottom or TA_Center);
     CL:=Round(Rad*BegAngle/1800*Pi);
     SetBkMode(Canvas.Handle,Transparent);
     NewFont:=CreateFontIndirect(LF);
     OldFont:=SelectObject(Canvas.Handle,NewFont);
     for I:=1 to Length(S) do
      begin
       W:=TextWidth(S[I]);
       Angle:=2*Pi*(CL-W/2)/L;
       TAngle:=Round((Angle/Pi)*1800-900);
       LF.lfEscapement:=TAngle;
       LF.lfOrientation:=TAngle;
       NewFont:=CreateFontIndirect(LF);
       DeleteObject(SelectObject(Canvas.Handle,NewFont));
       X:=X0+Round(Rad*Cos(Angle));
       Y:=Y0-Round(Rad*Sin(Angle));
       TextOut(X,Y,S[I]);
       Dec(CL,W)
      end;
     DeleteObject(SelectObject(Canvas.Handle,OldFont))
    end
  end;

procedure TForm1.BtnFontClick(Sender: TObject);
 begin
  if FontDialog.Execute then
   Repaint
 end;

procedure TForm1.FormCreate(Sender: TObject);
 begin
  S:='Королевство Delphi';
  Rad:=100;
  BegAngle:=1570;
  X0:=200;
  Y0:=300
 end;

procedure TForm1.BtnApplyClick(Sender: TObject);
 begin
  try
   S:=EditText.Text;
   Rad:=StrToInt(EditR.Text);
   BegAngle:=StrToInt(EditAngle.Text)*10;
   X0:=Rad+100;
   Y0:=Rad+200;
   Repaint
  except
   on EConvertError do
    ShowMessage('Ошибка в задании чисел')
  end
 end;

end.