[lazarus] Just for fun...
David Creelman
dave at geko.net.au
Mon Nov 4 07:27:22 EST 2002
Hi All,
As a kind of fun measure of how far along Lazarus is, I went to the
Delphi Superpage and downloaded a TGraphicControl descended component
just to see how easy it was to pull it into Lazarus.
I chose TMotoMeter, originally written for Delphi 1.0 by (B.
Drehzahlmesser ), which displays a simple speedometer with some danger
bands on it. There was a winprocs.Polygon call that needed to be
translated to a call to Polygon and a SetTextAlign command that needed
to be commented out (don't know it's equivalent in lcl land) and it
worked fine !
Here is a pic of it working and a copy of the source if you are
interested in toying around with it.
To get the speed marker to clear itself on a change, you'll need to
issue a refresh and it does flash a fair bit. I expect that will get
fixed later on.... Andreas, why does it flash like that ? Which part of
Graphics.pas needs to change here ?
Cheers
DC
{ **************************************************************************
* Die Unit MOTOMETR.PAS ist eine Delphi-Komponente, die ein KFZ- *
* Rundinstrument (z. B. Drehzahlmesser) simmuliert. *
* Über Properties kann das Aussehen eingestellt werden. *
* *
* Erstellt mit: Delphi 1.0 für Windows *
* Erstelldatum: 24.02.1996 (B. Bauer) *
* Letzte Aenderung: 12.12.1999 (B. Bauer), Optimiert fuer Delphi 4.0 *
************************************************************************** }
unit Motometro;
interface
uses
SysUtils, lcltype, GraphType,{WinTypes, WinProcs, Messages,} Classes, Graphics, Controls,
Forms, Dialogs;
type
TMotoMetr = class(TGraphicControl)
private
FMaxValue: Longint;
FCurPosition,FMinDangerZ,FMaxDangerZ: single;
FUnits,FTitle: string;
FMarks: Integer;
FDangerZone: Boolean;
FBackColor,FScaleColor,FFontColor,FNeedleColor,FDangerColor,FBorderColor: TColor;
FFontName: TFontName;
PosX, PosY, x,y,xS1,yS1,xS2,yS2, Radius: integer;
alpha_z, alpha_bog:real;
procedure PaintBackground(ACanvas: TCanvas);
procedure PaintNeedle(ICanvas: TCanvas);
procedure SetBackColor(Value: TColor);
procedure SetScaleColor(Value: TColor);
procedure SetFontColor(Value: TColor);
procedure SetNeedleColor(Value: TColor);
procedure SetPosition(Value: Single);
procedure SetMarks(Value: Integer);
procedure SetMaxValue(Value: Longint);
procedure SetUnits(Value: String);
procedure SetTitle(Value: String);
procedure SetDangerZone(Value: Boolean);
procedure SetMinDangerZ(Value: Single);
procedure SetMaxDangerZ(Value: Single);
procedure SetDangerColor(Value: TColor);
procedure SetFontName(Value: TFontName);
procedure SetBorderColor(Value: TColor);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
{Properties zum Einstellen des gewünschten Aussehens der Komponente}
property Align;
property FontName: TFontName read FFontName write SetFontName;
property ColorScale: TColor read FScaleColor write SetScaleColor;
property ColorBack: TColor read FBackColor write SetBackColor;
property ColorFont: TColor read FFontColor write SetFontColor;
property ColorNeedle: TColor read FNeedleColor write SetNeedleColor;
property MaxValue: Longint read FMaxValue write SetMaxValue;
property Position: Single read FCurPosition write SetPosition;
property Visible;
property Marks: Integer read FMarks write SetMarks;
property Units: String read FUnits write SetUnits;
property Title: String read FTitle write SetTitle;
property DangerZone: Boolean read FDangerZone write SetDangerZone;
property DangerZoneMin: Single read FMinDangerZ write SetMinDangerZ;
property DangerZoneMax: Single read FMaxDangerZ write SetMaxDangerZ;
property ColorDangerZ: TColor read FDangerColor write SetDangerColor;
property ColorBorder: TColor read FBorderColor write SetBorderColor;
end;
procedure Register;
implementation
constructor TMotoMetr.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csFramed, csOpaque];
Canvas.Font.Color:= ClWhite;
{Grundeinstellungen}
Height:=210;
Width:=210;
FCurPosition:=0;
FBackColor:=clSilver;
FScaleColor:=clBlack;
FFontColor:=clWhite;
FFontName:='Century Gothic';
FNeedleColor:=$000080FF;
FMarks:=7;
FMaxValue:=70;
FTitle:='x 100';
FUnits:='1/min';
FDangerZone:=True;
FMinDangerZ:=FMaxValue div 3;
FMaxDangerZ:=FMaxValue div 2;
FDangerColor:=clRed;
FBorderColor:=clGray;
end;
procedure TMotoMetr.Paint;
begin
with Canvas do
begin
PaintBackground(Canvas); {Hintergrundbitmap erstellen}
PaintNeedle(Canvas); {Zeiger des MotoMeters wird über das Bitmap gelegt}
end;
end;
{---------------------------------------------------------------------------
---- Hintergrund wird gezeichnet und als Bitmap im Speicher abgelegt -----
---------------------------------------------------------------------------}
procedure TMotoMetr.PaintBackground(ACanvas: TCanvas);
type TPolyArray= array[0..360] of TPoint;
PPolyArray= ^TPolyArray;
var
ARect: TRect;
alpha, i, j, k: integer;
Poly:PPolyArray;
startDanger,StopDanger:integer;
anzPoints:integer;
begin
If Width > Height then {Radius wird optimiert}
radius:=(Height div 2)-4;
If Width <= Height then
radius:=(Width div 2)-4;
PosX:=Width div 2;
PosY:=Height div 2;
alpha_z:=0;
with Canvas do
begin
ARect := Rect(0, 0, Width, Height);
Brush.Color:=ColorBack;
FillRect(ARect);
CopyRect(ARect, Canvas, ARect); {Hintergrundrechteck anlegen}
Brush.Color:=ColorScale;
Pen.Width:=3;
Pen.Color:=ColorBorder;
Ellipse(PosX-Radius-Pen.Width,PosY-Radius-Pen.Width, {Skala-Grundfläche}
PosX+Radius+Pen.Width,PosY+Radius+Pen.Width);
Pen.Width:=1;
Pen.Color:=ColorBorder;
Ellipse(PosX-Round(0.15*radius),PosY-Round(0.15*radius), {Umrandung}
PosX+Round(0.15*radius),PosY+Round(0.15*radius));
{Horizontale Textzentrierung mittels Handle über API-Funktion}
// SetTextAlign(ACanvas.Handle,TA_CENTER or TA_BOTTOM);
Font.Name:=FontName;
Font.Size:=Round((8*radius)/102);
Font.Color:=ColorFont;
Font.Style:=[];
TextOut(PosX,PosY-Round(radius*0.40),Title);
TextOut(PosX,PosY-Round(radius*0.25),Units);
TextOut(PosX,PosY+Round(radius*0.55),'© bb');
{-----------------------------------------------------------------------
"Roten Bereich" erstellen. Wird vom gewuenschten Wert
bis zum eingestellten Maximalwert gezeichnet}
if (DangerZone = True) and (MaxValue > DangerZoneMin) and (MaxValue > 0) then
begin
startDanger:=Round(270*DangerZoneMin/MaxValue);
stopDanger:=Round(270*DangerZoneMax/MaxValue);
AnzPoints:= (StopDanger-StartDanger+1)*2;
if anzPoints > 0 then
begin
getmem(Poly,(anzPoints+2)*Sizeof(TPoint));
for alpha := 0 to (AnzPoints div 2)-1 do
begin
alpha_bog:=((alpha+startDanger+135)/180)*Pi;
xS1:=Round(PosX+((radius)*cos(alpha_bog)));
yS1:=Round(PosY+((radius)*sin(alpha_bog)));
Poly^[alpha].x:=xS1;
Poly^[alpha].y:=yS1;
xS2:=Round(PosX+((radius-(radius*0.15))*cos(alpha_bog)));
yS2:=Round(PosY+((radius-(radius*0.15))*sin(alpha_bog)));
Poly^[AnzPoints-alpha-1].x:=xS2;
Poly^[AnzPoints-alpha-1].y:=yS2;
end;
Pen.Width:=3;
Pen.Color:=FDangerColor;
Brush.Color:=FDangerColor;
// winprocs.Polygon(Acanvas.handle,Poly^,AnzPoints);
Polygon(Poly^, AnzPoints, True);
freemem(Poly,(AnzPoints+2)*Sizeof(TPoint));
Brush.Color:=ColorScale;
end;
end;
Font.Size:=Round((9*radius)/102);
Font.Color:=ColorFont;
Font.Style:=[fsBold];
{-----------------------------------------------------------------------
Haupt-Skalenteilung und Beschriftung erstellen }
for i:= 0 to Marks do
if (MaxValue > 0) and (Marks > 0) then
begin
alpha_bog:=(alpha_z/180)*Pi+(135/180)*Pi;
x:=Round(PosX+((radius-radius*0.28)*cos(alpha_bog)));
y:=Round(PosY+((radius-radius*0.28)*sin(alpha_bog)));
{Berechnen der vertikalen Textanordnung
und der Skalierung in Bezug auf die Skalenteilung}
TextOut(x,(y+Round(TextHeight('A')/2)),FloatToStr(i*((MaxValue)/Marks)));
yS1:=Round(PosY+((radius)*sin(alpha_bog)));
xS1:=Round(PosX+((radius)*cos(alpha_bog)));
MoveTo(xS1,Ys1);
xS2:=Round(PosX+((radius-radius*0.15)*cos(alpha_bog)));
yS2:=Round(PosY+((radius-radius*0.15)*sin(alpha_bog)));
Pen.Width:=2;
Pen.Color:=ColorFont;
LineTo(xS2,yS2);
alpha_z:=alpha_z + (270/Marks);
end;
{-----------------------------------------------------------------------
Teilstriche anordnen }
alpha_z:=0;
for j := 0 to (Marks-1) do
begin
alpha_bog:=(alpha_z/180)*Pi+((135+(270/(2*Marks)))/180)*Pi;
yS1:=Round(PosY+((radius)*sin(alpha_bog)));
xS1:=Round(PosX+((radius)*cos(alpha_bog)));
MoveTo(xS1,Ys1);
xS2:=Round(PosX+((radius-radius*0.12)*cos(alpha_bog)));
yS2:=Round(PosY+((radius-radius*0.12)*sin(alpha_bog)));
Pen.Width:=1;
Pen.Color:=ColorFont;
LineTo(xS2,yS2);
alpha_z:=alpha_z + (270/Marks);
end;
CopyMode := cmSrcCopy;
end;
end;
{---------------------------------------------------------------------------
----------- Zeichnen und Bewegen der Nadel des MotoMeters ---------------
---------------------------------------------------------------------------}
procedure TMotoMetr.PaintNeedle(ICanvas: TCanvas);
var
alpha, xA,yA,xE,yE: integer;
begin
with Canvas do
If (MaxValue > 0) then
begin
If fCurPosition > MaxValue then fCurPosition := MaxValue;
If fCurPosition < 0 then fCurPosition := 0;
begin
alpha:=Round(fCurPosition*270/MaxValue); {Berechnen des Drehwinkels}
Pen.Color:=ColorNeedle;
Pen.Mode:= PMXOR;
Pen.Width:=2;
alpha_bog:=(alpha/180)*Pi+(135/180)*Pi;
xA:=Round(PosX+((radius-radius*0.15)*cos(alpha_bog)));
yA:=Round(PosY+((radius-radius*0.15)*sin(alpha_bog)));
xE:=Round(PosX+((radius-Round(Radius*0.85))*cos(alpha_bog)));
yE:=Round(PosY+((radius-Round(Radius*0.85))*sin(alpha_bog)));
MoveTo(xA,yA);
LineTo(xE,yE);
Pen.Mode:=PMCOPY;
end;
end;
end;
procedure TMotoMetr.SetPosition(Value: Single);
begin
if (FCurPosition <> Value) then
begin
PaintNeedle(Canvas);
FCurPosition := Value;
PaintNeedle(Canvas);
end;
end;
procedure TMotoMetr.SetBackcolor(Value: TColor);
begin
If Value <> FBackColor then
begin
FBackColor := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetScaleColor(Value: TColor);
begin
If Value <> FScaleColor then
begin
FScaleColor := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetFontColor(Value: TColor);
begin
If Value <> FFontColor then
begin
FFontColor := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetNeedleColor(Value: TColor);
begin
If Value <> FNeedleColor then
begin
FNeedleColor := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetMarks(Value: Integer);
begin
If Value <> FMarks then
begin
FMarks := Value;
Refresh
end;
end;
procedure TMotoMetr.SetMaxValue(Value: Longint);
begin
If Value <> FMaxValue then
begin
FMaxValue := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetUnits(Value: String);
begin
If Value <> FUnits then
begin
FUnits := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetTitle(Value: String);
begin
If Value <> FTitle then
begin
FTitle := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetDangerZone(Value: Boolean);
begin
If Value <> FDangerZone then
begin
FDangerZone := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetMinDangerZ(Value: Single);
begin
If Value <> FMinDangerZ then
begin
FMinDangerZ := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetMaxDangerZ(Value: Single);
begin
If Value <> FMaxDangerZ then
begin
FMaxDangerZ := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetDangerColor(Value: TColor);
begin
If Value <> FDangerColor then
begin
FDangerColor := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetFontName(Value: TFontName);
begin
If Value <> FFontName then
begin
FFontName := Value;
Refresh;
end;
end;
procedure TMotoMetr.SetBorderColor(Value: TColor);
begin
If Value <> FBorderColor then
begin
FBorderColor := Value;
Refresh;
end;
end;
{ Registrierung der Komponente}
procedure Register;
begin
RegisterComponents('Beispiele', [TMotoMetr]);
end;
end.
2002_11_04_232211_shot.jpg
unit ComponentTester;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, LResources, Buttons,
ExtCtrls, StdCtrls, ComCtrls, Motometro;
type
TForm1 = class(TForm)
Button1: TBUTTON;
Panel1: TPANEL;
Trackbar1: TTRACKBAR;
procedure Button1CLICK(Sender: TObject);
procedure Trackbar1CHANGE(Sender: TObject);
private
{ private declarations }
Mine : TMotoMetr;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{ TForm1 }
procedure TForm1.Button1CLICK(Sender: TObject);
begin
Mine := TMotoMetr.Create(Panel1);
// Mine.MaxValue := TrackBar1.Max;
Mine.Parent := Panel1;
Mine.Top := 0;
Mine.Width := Panel1.Width;
end;
procedure TForm1.Trackbar1CHANGE(Sender: TObject);
begin
Mine.Position := TrackBar1.Position;
Mine.Refresh;
end;
initialization
{$I componenttester.lrs}
end.
-------------- next part --------------
A non-text attachment was scrubbed...
Name: jpg00000.jpg
Type: application/octet-stream
Size: 15765 bytes
Desc: ""
Url : http://localhost/pipermail/lazarus/attachments/20021104/05f69d47/jpg00000.obj
More information about the Lazarus
mailing list