Форум: "Начинающим";
Текущий архив: 2006.11.05;
Скачать: [xml.tar.bz2];

Вниз

Помогите написать проаграмму для стрелки барометра.   Найти похожие ветки 

← →
Автоматчик   (2006-10-20 11:17) [0]

Давление вводится в Edit. Стрелка должна двигаться по круглому циферблату и отображать текущее давлени.

---

← →
icWasya ©   (2006-10-20 11:21) [1]

барометра нет есть часы

//Project1.dpr
program Project1;

uses
 Forms,
 Unit1 in "Unit1.pas" {Form1};

{$R *.res}

begin
 Application.Initialize;
 Application.CreateForm(TForm1, Form1);
 Application.Run;
end.

//Unit1.dfm
object Form1: TForm1
 Left = 420
 Top = 180
 Width = 484
 Height = 504
 Caption = "Form1"
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = "MS Sans Serif"
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 PixelsPerInch = 96
 TextHeight = 13
 object PaintBox1: TPaintBox
   Left = 0
   Top = 0
   Width = 476
   Height = 477
   Align = alClient
   OnPaint = PaintBox1Paint
 end
 object Timer1: TTimer
   Interval = 10
   OnTimer = Timer1Timer
   Left = 240
 end
end

//Unit1.pas
unit Unit1;

interface

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

type
 TForm1 = class(TForm)
   PaintBox1: TPaintBox;
   Timer1: TTimer;
   procedure PaintBox1Paint(Sender: TObject);
   procedure Timer1Timer(Sender: TObject);
   procedure FormCreate(Sender: TObject);
 private
   procedure DrowClock(PB:TPaintBox;CNV: TCanvas);
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

type TArrow =class
 private
   FWidth: Integer;
   FAngle: Double;
   FColor: TColor;
   FBrush: TPaintBox;
   X0,Y0:Double;
   FRadius: Double;
   FRadius2: Double;
   FRadius1: Double;
   procedure SetBrush(const Value: TPaintBox);
 public
   property Width:Integer read FWidth write FWidth;
   property Color:TColor read FColor write FColor;
   property Angle:Double read FAngle write FAngle;
   property Brush:TPaintBox read FBrush write SetBrush;
   property Radius:Double read FRadius write FRadius;
   property Radius1:Double read FRadius1 write FRadius1;
   property Radius2:Double read FRadius2 write FRadius2;
 public
   procedure Draw;
 end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
 DrowClock(TPaintBox(Sender),TPaintBox(Sender).Canvas);
end;

procedure TForm1.DrowClock(PB:TPaintBox;CNV:TCanvas);
var
 HH,NN,SS,ZZZ:Word;
 I:Integer;

var
 Arrow:TArrow;
 ArrowM:TArrow;
begin
 Arrow:=TArrow.Create;
 Arrow.Brush:=PB;

 ArrowM:=TArrow.Create;
 ArrowM.Brush:=PB;
 ArrowM.Y0:=ArrowM.Y0 * 1.7;
 ArrowM.Radius:=ArrowM.Radius /10;

 DecodeTime(Now,HH,NN,SS,ZZZ);
 Caption:=Format("%.2d:%.2d:%.2d",[hh,nn,ss]);

 ArrowM.Width:=2;
 ArrowM.Color:=$408000;
 for I:=1 to 10 do begin
   ArrowM.Radius1:=0.8;
   ArrowM.Radius2:=0.99;
   ArrowM.Angle:=I/10;
   ArrowM.Draw;
 end;

 Arrow.Width:=5;
 for I:=1 to 12 do begin
   Arrow.Radius1:=0.9;
   Arrow.Radius2:=0.99;
   Arrow.Angle:=(I/12);
   Arrow.Draw;
 end;

 Arrow.Width:=3;
 for I:=1 to 60 do begin
   Arrow.Radius1:=0.94;
   Arrow.Radius2:=0.96;
   Arrow.Angle:=(I/60);
   Arrow.Draw;
 end;

 ArrowM.Color:=0;
 ArrowM.Width:=1;
 ArrowM.Radius1:=0.9;
 ArrowM.Radius1:=0;
 ArrowM.Angle:=ZZZ/1000;
 ArrowM.Draw;

 Arrow.Color:=clGreen;
 Arrow.Width:=7;
 Arrow.Radius1:=-0.04;
 Arrow.Radius2:=0.6;
 Arrow.Angle:=(HH+NN/60+SS/3600)/12;
 Arrow.Draw;

 Arrow.Color:=clRed;
 Arrow.Width:=5;
 Arrow.Radius1:=-0.1;
 Arrow.Radius2:=0.9;
 Arrow.Angle:=(NN+SS/60+ZZZ/60000)/60;
 Arrow.Draw;

 Arrow.Width:=2;
 Arrow.Color:=0;
 Arrow.Radius2:=1;
 Arrow.Angle:=(SS+ZZZ/1000)/60;
 Arrow.Color:=$FFFFFF;
 Arrow.Draw;

 ArrowM.Free;
 Arrow .Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DoubleBuffered:=true;
end;

{ TArrow }

procedure TArrow.Draw;
var
 A,X,Y:Double;
begin
 FBrush.Canvas.Pen.Width:=FWidth;
 FBrush.Canvas.Pen.Color:=FColor;

   A:=( FAngle ) * (2*Pi);
   X:=  FRadius*FRadius2* Sin(A);
   Y:= -FRadius*FRadius2* Cos(A);

 FBrush.Canvas.MoveTo (Trunc(X0+X) ,Trunc(Y0+Y) );

   X:=  FRadius*FRadius1* Sin(A);
   Y:= -FRadius*FRadius1* Cos(A);

 FBrush.Canvas.LineTo (Trunc(X0+X) ,Trunc(Y0+Y) );

end;

procedure TArrow.SetBrush(const Value: TPaintBox);
begin
 FBrush := Value;

 X0:=FBrush.Width/2;
 Y0:=FBrush.Height/2;
 if FBrush.Width>FBrush.Height then FRadius:=Y0 else FRadius:=X0;

end;

end.


---

← →
ЮЮ ©   (2006-10-20 11:21) [2]

Неужели Автомат накрылся?
Наверное надо искать сайт "Полных Альтруистов". Вот если проблемы возникнут при самостоятельном решении - тогда сюда

---

← →
ЮЮ ©   (2006-10-20 11:23) [3]

Однако, я поспешил с выводами :)

---

← →
default ©   (2006-10-20 11:23) [4]

не позорь автоматчиков

---

Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2006.11.05;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.46 MB
Время: 0.053 c