procedure TForm1.FormCreate(Sender: TObject);
begin
FWMeter := TWindMeter.Create(Self);
FWMeter.Parent := Self;
FWMeter.Width := 200;
FWMeter.Height := 200;
FWMeter.Color := clBtnFace;
FWMeter.Font.Size := 16;
FWMeter.Colors[wmeArrow] := clGreen;
FWMeter.Colors[wmeCircle] := clWhite;
FWMeter.Colors[wmeRing] := clBlue;
FWMeter.Colors[wmeCaptionBg] := clBlue;
FWMeter.TickLength := 10;
FWMeter.CaptionFont.Size := 15;
FWMeter.FooterFont.Size := 8;
FWMeter.Angle := 100;
end;
unit wmeter;
interface
uses
Windows, Messages, Classes, Graphics, Controls;
type
TWindMeterElements = (wmeArrow, wmePin, wmeRing, wmeCaptionBg, wmeCircle);
TWindMeter = class(TGraphicControl)
private
FFooterText: string;
FCaptionFont: TFont;
FFooterFont: TFont;
FAngle: Integer;
FMinAngle: Integer;
FMaxAngle: Integer;
FTickLength: Integer;
FColors: array[TWindMeterElements] of TColor;
procedure SetCaptionFont(const Value: TFont);
procedure SetFooterFont(const Value: TFont);
procedure SetAngle(const Value: Integer);
procedure SetTickLength(const Value: Integer);
function GetColors(Element: TWindMeterElements): TColor;
procedure SetColors(Element: TWindMeterElements; const Value: TColor);
procedure SetMaxAngle(const Value: Integer);
procedure SetMinAngle(const Value: Integer);
protected
function Center: TPoint; virtual;
function Radius: Integer; virtual;
procedure DrawArrow(Angle: Double); virtual;
procedure DrawRing; virtual;
procedure DrawLabel(Angle: Double; const LabelText: string); virtual;
procedure DrawTick(Angle: Double; Length: Integer); virtual;
procedure DrawCaption; virtual;
procedure DrawFooter; virtual;
procedure ChangeHandler(Sender: TObject);
public
procedure Paint; override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Colors[Element: TWindMeterElements]: TColor read GetColors write SetColors;
published
property Caption;
property Font;
property Color;
property CaptionFont: TFont read FCaptionFont write SetCaptionFont;
property FooterFont: TFont read FFooterFont write SetFooterFont;
property Angle: Integer read FAngle write SetAngle;
property MinAngle: Integer read FMinAngle write SetMinAngle;
property MaxAngle: Integer read FMaxAngle write SetMaxAngle;
property TickLength: Integer read FTickLength write SetTickLength;
end;
implementation
uses
Math;
constructor TWindMeter.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csOpaque];
Width := 200;
Height := 200;
FTickLength := 10;
Font.Size := 10;
Color := clWhite;
Caption := 'Wind Direction';
FFooterText := 'Footer';
FMinAngle := 0;
FMaxAngle := 360;
FCaptionFont := TFont.Create;
FCaptionFont.Assign(Font);
FCaptionFont.Style := [fsBold];
FCaptionFont.Color := clWhite;
FCaptionFont.OnChange := ChangeHandler;
FFooterFont := TFont.Create;
FFooterFont.Assign(Font);
FFooterFont.OnChange := ChangeHandler;
Colors[wmeArrow] := clRed;
Colors[wmePin] := clBlack;
Colors[wmeRing] := clBlack;
Colors[wmeCaptionBg] := clBlack;
Colors[wmeCircle] := Color;
end;
destructor TWindMeter.Destroy;
begin
FCaptionFont.Free;
FFooterFont.Free;
inherited;
end;
function TWindMeter.Center: TPoint;
begin
Result := Point(Width div 2, Height div 2);
end;
function TWindMeter.Radius: Integer;
var capH, footH, labH: Integer;
begin
Canvas.Font := FCaptionFont;
capH := Canvas.TextHeight('1');
Canvas.Font := Font;
labH := Canvas.TextHeight('1');
Canvas.Font := FFooterFont;
footH := Canvas.TextHeight('1');
Result := (Height - labH*2 - capH - footH - 16) div 2;
if Result > (Width - labH) div 2 - 16 then
Result := (Width - labH) div 2 - 16;
end;
procedure TWindMeter.DrawArrow(Angle: Double);
var cntr: TPoint;
majorR, R0, R1, R2: Integer;
XX, YY, Xa, Ya, Xb, Yb: Integer;
a, aa, ab: Double;
begin
a := Angle*PI/180;
cntr := Center;
majorR := Radius;
R0 := majorR div 12;
R1 := majorR div 6;
R2 := majorR - FTickLength;
XX := Round( Sin(a)*R2 ) + cntr.X;
YY := - Round( Cos(a)*R2 ) + cntr.Y;
Canvas.Pen.Color := Colors[wmeArrow];
Canvas.Brush.Color := Colors[wmeArrow];
Canvas.Ellipse(cntr.X - R1, cntr.Y - R1, cntr.X + R1+1, cntr.Y + R1+1);
aa := a - PI/2;
Xa := Round( Sin(aa)*R1 ) + cntr.X;
Ya := - Round( Cos(aa)*R1 ) + cntr.Y;
ab := a + PI/2;
Xb := Round( Sin(ab)*R1 ) + cntr.X;
Yb := - Round( Cos(ab)*R1 ) + cntr.Y;
Canvas.Polygon([Point(XX, YY), Point(Xa, Ya), Point(Xb, Yb)]);
Canvas.Pen.Color := Colors[wmePin];
Canvas.Brush.Color := Colors[wmePin];
Canvas.Ellipse(cntr.X - R0, cntr.Y - R0, cntr.X + R0+1, cntr.Y + R0+1);
end;
procedure TWindMeter.DrawLabel(Angle: Double; const LabelText: string);
var XX, YY, X0, Y0: Integer;
labelR, txtH, txtW: Integer;
cntr: TPoint;
a: Double;
begin
a := Angle*PI/180;
cntr := Center;
txtH := Canvas.TextHeight(LabelText);
txtW := Canvas.TextWidth(LabelText);
labelR := Radius + Round( txtH*0.4*Sqr(cos(a)) + txtW*0.6*Sqr(sin(a)) ) + 4;
XX := Round( Sin(a)*labelR ) + cntr.X;
YY := - Round( Cos(a)*labelR ) + cntr.Y;
X0 := XX - txtW div 2;
Y0 := YY - txtH div 2;
Canvas.Font := Font;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(X0, Y0, LabelText);
Canvas.Brush.Style := bsSolid;
end;
procedure TWindMeter.DrawRing;
var cntr: TPoint;
majorR: Integer;
begin
cntr := Center;
majorR := Radius;
Canvas.Pen.Color := Colors[wmeRing];
Canvas.Brush.Color := Colors[wmeCircle];
Canvas.Ellipse(cntr.X - majorR, cntr.Y - majorR,
cntr.X + majorR, cntr.Y + majorR);
end;
procedure TWindMeter.DrawTick(Angle: Double; Length: Integer);
var X0, Y0, X1, Y1: Integer;
majorR, minorR: Integer;
cntr: TPoint;
a: Double;
begin
a := Angle*PI/180;
cntr := Center;
majorR := Radius;
minorR := Radius - Length;
X0 := Round( Sin(a)*minorR ) + cntr.X;
Y0 := - Round( Cos(a)*minorR ) + cntr.Y;
X1 := Round( Sin(a)*majorR ) + cntr.X;
Y1 := - Round( Cos(a)*majorR ) + cntr.Y;
Canvas.MoveTo(X0, Y0);
Canvas.LineTo(X1, Y1);
end;
procedure TWindMeter.Paint;
var angle: Integer;
nticks: Integer;
begin
inherited;
Canvas.Brush.Color := Color;
Canvas.FillRect(ClientRect);
DrawRing;
nticks := 16;
for angle := 0 to nticks-1 do
DrawTick(angle*360/nticks, FTickLength);
Canvas.Font.Assign(Font);
DrawLabel(0, 'N');
DrawLabel(45, 'NE');
DrawLabel(90, 'E');
DrawLabel(90+45, 'SE');
DrawLabel(180, 'S');
DrawLabel(180+45, 'SW');
DrawLabel(270, 'W');
DrawLabel(270+45, 'NW');
DrawArrow(FAngle);
DrawCaption;
DrawFooter;
end;
procedure TWindMeter.DrawCaption;
var txtH, txtW: Integer;
R: TRect;
begin
Canvas.Font.Assign(FCaptionFont);
txtH := Canvas.TextHeight(Caption);
txtW := Canvas.TextWidth(Caption);
R := ClientRect;
R.Bottom := R.Top + txtH + 2;
Canvas.Brush.Color := Colors[wmeCaptionBg];
Canvas.TextRect(R, (Width - txtW) div 2, 1, Caption);
end;
procedure TWindMeter.DrawFooter;
var txtH, txtW: Integer;
R: TRect;
begin
Canvas.Font.Assign(FFooterFont);
txtH := Canvas.TextHeight(FFooterText);
txtW := Canvas.TextWidth(FFooterText);
R := ClientRect;
R.Top := R.Bottom - txtH - 2;
Canvas.Brush.Color := Color;
Canvas.TextRect(R, (Width - txtW) div 2, R.Top + 1, FFooterText);
end;
procedure TWindMeter.ChangeHandler(Sender: TObject);
begin
Refresh;
end;
procedure TWindMeter.SetCaptionFont(const Value: TFont);
begin
FCaptionFont.Assign(Value);
end;
procedure TWindMeter.SetFooterFont(const Value: TFont);
begin
FFooterFont.Assign(Value);
end;
procedure TWindMeter.SetAngle(const Value: Integer);
begin
if FAngle <> Value then
begin
if (Value >= FMinAngle)and(Value <= FMaxAngle) then
begin
FAngle := Value;
Refresh;
end;
end;
end;
procedure TWindMeter.SetTickLength(const Value: Integer);
begin
if FTickLength <> Value then
begin
FTickLength := Value;
Refresh;
end;
end;
function TWindMeter.GetColors(Element: TWindMeterElements): TColor;
begin
Result := FColors[Element];
end;
procedure TWindMeter.SetColors(Element: TWindMeterElements; const Value: TColor);
begin
if FColors[Element] <> Value then
begin
FColors[Element] := Value;
Refresh;
end;
end;
procedure TWindMeter.SetMaxAngle(const Value: Integer);
begin
if FMaxAngle <> Value then
begin
FMaxAngle := Value;
if FAngle > FMaxAngle then
FAngle := FMaxAngle;
Refresh;
end;
end;
procedure TWindMeter.SetMinAngle(const Value: Integer);
begin
if FMinAngle <> Value then
begin
FMinAngle := Value;
if FAngle < FMinAngle then
FAngle := FMinAngle;
Refresh;
end;
end;
end.