Нарисовать стрелку как у аналоговых приборов

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls;
 
type
  TImage = class(ExtCtrls.TImage)
  private
    FSwivel: Integer;
    FScale: TBitmap;
    procedure SetScale();
    procedure SetSwivel(ASwivel: Integer);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Swivel: Integer read FSwivel write SetSwivel;
    property Scale: TBitmap read FScale;
  end;
 
  TForm1 = class(TForm)
    Panel1: TPanel;
    Image1: TImage;
    TrackBar1: TTrackBar;
    procedure FormCreate(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
end;
 
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  Image1.Swivel := TrackBar1.Position;
end;
 
{ TImage }
 
constructor TImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  
  FScale := TBitmap.Create;
  FScale.Width := 800;
  FScale.Height := 500;
  SetScale();
 
  Center := True;
  Stretch := True;
  Proportional := True;
 
  Swivel := 0;
end;
 
destructor TImage.Destroy;
begin
  FScale.Free;
  inherited;
end;
 
//procedure TImage.WMPaint(var Message: TWMPaint);
procedure TImage.Paint;
const
{$J+}
  b: Boolean = True;
{$J-}
var
  Xo, Yo, R: Integer;
  A: Real;
begin
  inherited;
 
  b := not b;
  if {Proportional and} b then Exit;
 
  Picture.Assign(FScale);
 
  Xo := 400;
  Yo := 400;
  R := 300;
  A := FSwivel * pi / 180;
 
  with Canvas, Pen do
  begin
    Width := 5;
    Color := clRed;
    MoveTo(Xo, Yo);
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
  end; 
end;
 
procedure TImage.SetScale;
var
  i, j,
  Xo, Yo,
  X, Y,
  R,
  A1, A2: Integer;
 
  A, dA: Real;
 
  s: String;
 
begin
  Xo := 400;
  Yo := 400;
  R := 300;
  A1 := 150;
  A2 := -120;
  A := A1 * pi / 180;
  dA := A2 / (4 * 5) * pi / 180;
 
  with FScale.Canvas, Pen do
  begin
 
    Brush.Style := bsClear;
    Brush.Color := clMoneyGreen;
    Font.Size := 16;
 
    FillRect(ClipRect);
 
    Width := 20;
    Color := clWhite;
    Ellipse(Xo - R, Yo - R, Xo + R, Yo + R);
 
    Width := 5;
    Color := clBlue;
    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    AngleArc(FScale.Canvas.Handle, Xo, Yo, R, A1, A2);
 
    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
 
    s := IntToStr(0);
    MoveTo(Xo + Round((R + 50) * cos(A)), Yo - Round((R + 50) * sin(A)));
    TextOut(PenPos.X - TextWidth(s) div 2, PenPos.Y - TextHeight(s) div 2, s);
 
    for i := 1 to 4 do
    begin
      for j := 1 to 4 do
      begin
        A := A + dA;
        MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
        LineTo(Xo + Round((R + 15) * cos(A)), Yo - Round((R + 15) * sin(A)));
 
        s := IntToStr(i-1) + ',' + IntToStr(2 * j);
        X := Xo + Round((R + 30) * cos(A) - TextWidth(s)  / 2);
        Y := Yo - Round((R + 30) * sin(A) + TextHeight(s) / 2);
        TextOut(X, Y, s);
      end;
 
      A := A + dA;
      MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
      LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
 
      s := IntToStr(i);
      X := Xo + Round((R + 50) * cos(A) - TextWidth(s)  / 2);
      Y := Yo - Round((R + 50) * sin(A) + TextHeight(s) / 2);
      TextOut(X, Y, s);
    end;
  end;
end;
 
procedure TImage.SetSwivel(ASwivel: Integer);
begin
  FSwivel := 150 - ASwivel;
  Repaint;
end;
 
end.

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls, StdCtrls;
 
type
  TPanel = class(ExtCtrls.TPanel)
  private
    A1: Integer;  // íà÷àëî øêàëû (â ãðàäóñàõ)
    A2: Integer;  // ðàçìàõ øêàëû (â ãðàäóñàõ)
    FnBSerif,            // ÷èñëî áîëüøèõ çàñå÷åê íà øêàëå
    FnSSerif: Integer;   // ÷èñëî ìàëåíüêèõ çàñå÷åê íà øêàëå
    MinValue: Real; // ìèí. çíà÷åíèå øêàëû (â ïîïóãàÿõ)
    MaxValue: Real; // ìàêñ. çíà÷åíèå øêàëû (â ïîïóãàÿõ)
    ValueFormat: String; // ôîðìàò îòîáðàæåíèÿ çíà÷åíèé øêàëû(èç FormatFloat)
    FSwivel: Integer; // óãîë ïîâîðîòà ñòðåëêè (â ãðàäóñàõ)
    FNewSwivel: Integer; // íîâûé óãîë ïîâîðîòà ñòðåëêè (â ãðàäóñàõ)
    FScale,              // èçîáðàæåíèå øêàëû
    tmp: TBitmap;
    Timer1: TTimer;      // òàéìåð ïëàâíîãî ïåðåìåùåíèÿ øêàëû
    procedure SetScale();
    procedure SetSwivel(ASwivel: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure SetValue(AValue: Real);
    function GetValue(): Real;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
 
  published
    property Value: Real read GetValue write SetValue;
    property Swivel: Integer read FSwivel write SetSwivel;
    property Scale: TBitmap read FScale;
  end;
 
  TForm1 = class(TForm)
    Panel1: TPanel;
    TrackBar1: TTrackBar;
    Edit1: TEdit;
    Button1: TButton;
    procedure TrackBar1Change(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
//==============================================================================
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  Panel1.Swivel := TrackBar1.Position;
  Caption := FloatToStr(Panel1.Value);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Panel1.Value := StrToFloat(Edit1.Text);
end;
//==============================================================================
{ TPanel }
 
constructor TPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
 
  DoubleBuffered := True;
  
  tmp := TBitmap.Create;
  tmp.Canvas.Pen.Width := 5;
  tmp.Canvas.Pen.Color := clRed;
 
  FScale := TBitmap.Create;
  FScale.Width := 800;
  FScale.Height := 500;
 
  FnBSerif := 8;
  FnSSerif := 4;
 
  SetScale();
 
//  Center := True;
//  Stretch := True;
//  Proportional := True;
 
  Timer1 := TTimer.Create(Self);
  Timer1.Enabled := False;
  Timer1.Interval := 50;
  Timer1.OnTimer := Timer1Timer;
 
  Swivel := 0;
end;
 
destructor TPanel.Destroy;
begin
  Timer1.Free;
  FScale.Free;
  tmp.Free;
  inherited;
end;
 
//procedure TImage.WMPaint(var Message: TWMPaint);
procedure TPanel.Paint;
//const
{.$J+}
//  b: Boolean = True;
{.$J-}
var
  Xo, Yo, R: Integer;
  A: Real;
begin
  inherited;
 
//  b := not b;
//  if {Proportional and} b then Exit;
 
//  Picture.Assign(FScale);
  tmp.Assign(FScale);
 
  Xo := 400;
  Yo := 400;
  R := 300;
  A := FSwivel * pi / 180;
 
  with tmp.Canvas, Pen do
  begin
//    Width := 5;
//    Color := clRed;
    MoveTo(Xo, Yo);
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
  end;
 
  StretchBlt(Canvas.Handle, 0, 0, Width, Height, tmp.Canvas.Handle,
             0, 0, tmp.Width, tmp.Height, SRCCOPY);
end;
 
procedure TPanel.SetScale;
var
  i, j,
  Xo, Yo,
  X, Y,
  R: Integer;
  A, dA: Real;
 
  s: String;
 
begin
  Xo := 400;
  Yo := 400;
  R := 300;
  A2 := -200;
  A1 := 180 - ((180 + A2) div 2);
 
  // óñòàíîâêà ÷èñëà äåëåíèé
  Form1.TrackBar1.Max := Abs(A2);//A1 + A2 âûíåñòè èç êëàññà êàê ñâ-âà
//  Form1.TrackBar1.Min := A1;
 
  A := A1 * pi / 180;
  dA := A2 / (FnBSerif * (FnSSerif + 1)) * pi / 180;
 
  MinValue := -3;
  MaxValue := 5;
 
  ValueFormat := '0.0';
 
  with FScale.Canvas, Pen do
  begin
 
    Brush.Color := clMoneyGreen;
    FillRect(ClipRect);
 
    Brush.Style := bsClear;
    Font.Size := 16;
    Width := 20;
    Color := clWhite;
    Ellipse(Xo - R, Yo - R, Xo + R, Yo + R);
 
    Width := 5;
    Color := clBlue;
    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    Windows.AngleArc(FScale.Canvas.Handle, Xo, Yo, R, A1, A2);
 
    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
 
    s := FormatFloat(ValueFormat, MinValue);
    MoveTo(Xo + Round((R + 50) * cos(A)), Yo - Round((R + 50) * sin(A)));
    TextOut(PenPos.X - TextWidth(s) div 2, PenPos.Y - TextHeight(s) div 2, s);
 
    for i := 0 to FnBSerif - 1 do
    begin
      for j := 1 to FnSSerif do
      begin
        A := A + dA;
        MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
        LineTo(Xo + Round((R + 15) * cos(A)), Yo - Round((R + 15) * sin(A)));
 
//        s := IntToStr(i-1) + ',' + IntToStr(2 * j);
        s := FormatFloat(ValueFormat, MinValue + (MaxValue - MinValue) / (FnBSerif * (FnSSerif - 1)) * (i * FnBSerif + j));
        X := Xo + Round((R + 30) * cos(A) - TextWidth(s)  / 2);
        Y := Yo - Round((R + 30) * sin(A) + TextHeight(s) / 2);
        TextOut(X, Y, s);
      end;
 
      A := A + dA;
      MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
      LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
 
//      s := IntToStr(i);
      s := FormatFloat(ValueFormat, MinValue + (MaxValue - MinValue) / FnBSerif * (i + 1));
      X := Xo + Round((R + 50) * cos(A) - TextWidth(s)  / 2);
      Y := Yo - Round((R + 50) * sin(A) + TextHeight(s) / 2);
      TextOut(X, Y, s);
    end;
  end;
end;
 
procedure TPanel.SetSwivel(ASwivel: Integer);
begin
  FNewSwivel := A1 - ASwivel;
  if Abs(FSwivel - FNewSwivel) < 5 then
    FSwivel := FNewSwivel
  else
    Timer1.Enabled := True;
  Repaint;
end;
 
procedure TPanel.SetValue(AValue: Real);
begin
  if AValue < MinValue then
    Swivel := 0
  else
    if AValue > MaxValue then
      Swivel := -A2
    else
    begin
      Swivel := Round(-A2 / (MaxValue - MinValue) * (AValue - MinValue));
    end;
end;
 
function TPanel.GetValue: Real;
begin
  Result := MinValue - (MaxValue - MinValue) / A2 * (A1 - FSwivel);
end;
 
procedure TPanel.Timer1Timer(Sender: TObject);
begin
  if FSwivel <> FNewSwivel then
  begin
    FSwivel := FSwivel + (FNewSwivel - FSwivel) div 5 + (FNewSwivel - FSwivel) mod 5;
  end else
    Timer1.Enabled := False;
  Repaint;
  Form1.Caption := FloatToStr(Value);
end;
 
end.