开源控件大家做（4）仪表盘

逍遥派掌门人 · 发表于 2012-6-1 17:57:21

下面的是仪表盘的控件的代码：

unit Mymeter;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,windows;
const
orid=5;
type
TMymeter = class(TPaintBox)
private
{ Private declarations }
FA1:integer; // 圆环的分度
FColorA1:Tcolor; // 圆环的分度左半颜色
FColorA2:Tcolor; // 圆环的分度右半颜色
FDialcolor:Tcolor; // 表盘刻度线的颜色
FTitlecolor:Tcolor; // 表盘标题的颜色
FValuecolor:Tcolor; // 数字示值的颜色
FBKcolor:Tcolor; // 表盘的背景颜色
FNeedlecolor:Tcolor; // 指针颜色
FMinvalue,FMaxvalue, // 表盘的最小，最大值
FValue:Single; // 表盘的当前值
FDistance:integer; // 用于调整的
FDivide_number:integer; // 表盘的分度
FXWidth,FYHeight:integer; // 表盘的长宽
FCX,FCY,FCR,FCRWidth:integer; // FCX,FCY 为指针的圆心位置，FCR半径，FCRWidth 圆弧宽度
procedure PaintCir();
procedure Paintbigdial;
procedure Paintsmalldial;
procedure PaintNeedle(A:single);
procedure setbkground;
procedure SA1(A:integer);
procedure SColorA1(A:Tcolor);
procedure SColorA2(A:Tcolor);
procedure SBKColor(A:Tcolor);
procedure SNeedlecolor(A:Tcolor);
procedure SDialcolor(A:Tcolor);
procedure SMinvalue(A:single);
procedure SMaxvalue(A:single);
procedure SDivide_number(A:integer);
procedure SValue(A:single);
procedure SCRWidth(A:integer);
procedure SDistance(A:integer);
protected
{ Protected declarations }
procedure PlotArc(const fCanvas: TCanvas;
const Center: TPoint;
const Radius: Integer;
const StartAngle: Single;
const StopAngle: Single);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy;override;
procedure Paint; override;
procedure init;
published
{ Published declarations }
property A1: integer Read FA1 Write SA1;
property ColorA1: Tcolor Read FColorA1 write SColorA1;
property ColorA2: Tcolor Read FColorA2 write SColorA2;
property BKcolor: Tcolor Read FBKcolor write SBKColor;
property Needlecolor:Tcolor read FNeedlecolor write SNeedlecolor;
property Dialcolor :Tcolor read FDialcolor write SDialcolor;
property Minvalue : Single Read FMinvalue write SMinvalue ;
property Maxvalue : Single Read FMaxvalue write SMaxvalue ;
property Divide_number:integer read FDivide_number write Sdivide_number;
property Value : Single Read FValue write SValue;
property CRWidth :integer Read FCRWidth write SCRWidth;
property Distance:integer Read FDistance write SDistance;
end;
procedure Register;
implementation
procedure Register;
begin
{$I mymeter_icon.lrs}
RegisterComponents('fpccn',[TMymeter]);
end;
constructor TMymeter.Create(AOwner: TComponent);
begin
FA1:=30;
FColorA1:=clLime;
FColorA2:= Clred;
FBKColor:=clyellow;
FNeedlecolor:=clblue;
FDialcolor:=clblack;
FValuecolor:=clblack;
FCRWidth := 6;
FMinvalue:=0.0;
FMaxvalue:=50.0;
FValue:=0.0;
FXWidth:=self.Width;
FYHeight:=self.Height;
FDistance:=10;
FDivide_number:=5;
init;
inherited;
end;
destructor TMymeter.Destroy;
begin
inherited Destroy;
end;
procedure TMymeter.PlotArc(const fCanvas: TCanvas;
const Center: TPoint;
const Radius: Integer;
const StartAngle: Single;
const StopAngle: Single);
function GetPositionForAngle(const Angle: Single): TPoint;
var
CosAngle: single;
SinAngle: single;
begin
SinAngle:=sin((angle-90)*PI/180); // 将坐标旋转90，符合视觉
CosAngle:=cos((angle-90)*PI/180);
Result.X := Round(Center.X + Radius * SinAngle);
Result.Y := Round(Center.Y - Radius * CosAngle);
end;
var
Index: Integer;
begin
with GetPositionForAngle(StartAngle) do fCanvas.MoveTo(X, Y);
for Index := round(StartAngle) to round(StopAngle) do
with GetPositionForAngle(Index) do fCanvas.LineTo(X, Y);
with GetPositionForAngle(StopAngle) do fCanvas.LineTo(X, Y);
end;
procedure TMymeter.SA1(A:integer);
begin
if FA1=A then exit;
FA1:=A;
if (FA1 < round(FMinvalue)) then FA1:= round(FMinvalue);
if (FA1> round(FMaxvalue)) then FA1:= round(FMaxvalue); //A1非法输入时初始化
Refresh;
end;
procedure TMymeter.SColorA1(A:Tcolor);
begin
if FColorA1=A then exit;
FColorA1:=A;
Refresh;
end;
procedure TMymeter.SColorA2(A:Tcolor);
begin
if FColorA2=A then exit;
FColorA2:=A;
Refresh;
end;
procedure TMymeter.SNeedlecolor(A:Tcolor);
begin
if FNeedlecolor=A then exit;
FNeedlecolor:=A;
Refresh;
end;
procedure TMymeter.SBKColor(A:Tcolor);
begin
if FBKColor=A then exit;
FBKColor:=A;
Refresh;
end;
procedure TMymeter.SDialcolor(A:Tcolor);
begin
if FDialcolor=A then exit;
FDialcolor:=A;
Refresh;
end;
procedure TMymeter.Sminvalue(A:single);
begin
if FMinvalue=A then exit;
FMinvalue:=A;
Refresh;
end;
procedure TMymeter.Smaxvalue(A:single);
begin
if FMaxvalue=A then exit;
FMaxvalue:=A;
Refresh;
end;
procedure TMymeter.Sdivide_number(A:integer);
begin
if FDivide_number=A then exit;
FDivide_number:=A;
Refresh;
end;
procedure TMymeter.Svalue(A:single);
var
temp1,temp2:tcolor;
begin
if (Fvalue=A) then exit;
if (A < FMinvalue) then A:=FMinvalue
else if (A > FMaxvalue) then A:=FMaxvalue;
temp1:=FNeedlecolor;
temp2:=canvas.Font.Color;
FNeedlecolor:=FBKColor;
canvas.Font.Color:=FBKColor;
PaintNeedle(Fvalue);
Fvalue:=A;
FNeedlecolor:=temp1;
canvas.Font.Color:=temp2;
PaintNeedle(Fvalue);
end;
procedure TMymeter.SCRWidth(A:integer);
begin
if (FCRWidth=A) then exit;
FCRWidth:=A;
Refresh;
end;
procedure TMymeter.Sdistance(A:integer);
begin
if (FDistance=A) then exit;
FDistance:=A;
Refresh;
end;
procedure TMymeter.init;
begin
FXWidth:=self.Width;
FYHeight:=self.Height;
FCR:=((FXwidth - FCRWidth- Fdistance) * 4 div 5) div 2;
FCX := FXwidth div 2;
if (FCRWidth > 20) then FCY :=FYHeight - FCRWidth
else FCY :=FYHeight - 20;
end;
procedure TMymeter.PaintCir();
var
i,a: Integer;
kk:Tpoint;
begin
kk.x:=FCX;
kk.y:=FCY;
with Canvas do
begin
Pen.Style := psSolid;
Pen.Width:=2;
a:=round((FA1 - FMinvalue) * 180 / (FMaxvalue - FMinvalue));
for i:=1 to FCRWidth do
begin
Pen.Color := ColorA1;
PlotArc(canvas,kk,FCR+i+FCRWidth div 2,0,a);
Pen.Color := ColorA2;
PlotArc(canvas,kk,FCR+i+FCRWidth div 2,a,180);
end;
Pen.Width:=1;
Pen.Color := clblack;
PlotArc(canvas,kk,FCR+ FCRWidth div 2,0,180);
PlotArc(canvas,kk,FCR + FCRWidth + FCRWidth div 2 + 1,0,180);
end;
end;
procedure TMymeter.Paintbigdial;
var
x,y,x1,y1,x2,y2,y3,Len:integer;
radian, isValue, A,B,C,D,E:single;
strtemp:string;
begin
with Canvas do
begin
Brush.Style:=bsclear;
Pen.Width:=2;
Pen.Color := FDialcolor;
if (FDivide_number<>0) then B:=180 / FDivide_number
else B:=90;
C:=(FMaxvalue-FMinvalue) / FDivide_number ;
Len:=FCR + FCRWidth + FCRWidth div 2;
for y3:=0 to FDivide_number do
begin
A:=B * y3;
E:=A-90;
radian:= E * PI / 180;
x:=Round(Len*sin(radian));
y:=Round(Len*cos(radian));
x1:=Round((Len-FCRWidth )*sin(radian));
y1:=Round((Len-FCRWidth )*cos(radian));
Pen.Width:=2;
Pen.Color := FDialcolor;
MoveTo(FCX+x1,FCY-y1);
LineTo(FCX+x,FCY-y);
if ((y3 = 0) or (y3=FDivide_number)) then
begin
E:=A-90;
radian:= E * PI / 180;
x2:=Round((Len+FCRWidth)*sin(radian))-font.Size;
y2:=Round((Len+FCRWidth)*cos(radian))+font.Size;
end
else begin
E:=A-90 -2;
radian:= E * PI / 180;
x2:=Round((Len+FCRWidth+5)*sin(radian));
y2:=Round((Len+FCRWidth+5)*cos(radian));
end;
isvalue:= FMinvalue + y3 * C;
Pen.Width:=1;
Pen.Color := FValuecolor;
if ((y3 = 0) or (y3=FDivide_number)) then D:=0
else D:= 90- A;
font.Orientation:=round(D*10) ;
strtemp := format('%0.0f',[isvalue]);
TextOut(FCX+x2,FCY-y2,strtemp);
end;
font.Orientation:=0;
end;
end;
procedure TMymeter.Paintsmalldial;
var
x,y,x1,y1,x2,Len:integer;
radian,A,B: single;
begin
with Canvas do
begin
Pen.Width:=1;
Pen.Color := FDialcolor;
Len:=FCR+FCRWidth;
if (FDivide_number<>0) then B:=180 / (FDivide_number *orid)
else B:=90;
for x2:=0 to (FDivide_number * orid) do
begin
A:= B * x2;
radian:= (A-90)*PI/180;
x:=Round((Len)*sin(radian));
y:=Round((Len)*cos(radian));
x1:=Round((Len-FCRWidth/2)*sin(radian));
y1:=Round((Len-FCRWidth/2)*cos(radian));
MoveTo(FCX+x1,FCY-y1);
LineTo(FCX+x,FCY-y);
end;
end;
end;
procedure TMymeter.PaintNeedle(A:single);
var
x,y:integer;
radian,B: single;
begin
with Canvas do
begin
Pen.Width:=3;
Pen.Color := FNeedlecolor;
if (A=FMaxvalue) then B:=180
else B:= (A -FMinvalue) * 180 / (FMaxvalue-FMinvalue);
radian:= (B-90) * Pi /180;
x:=Round(FCR*sin(radian));
y:=Round(FCR*cos(radian));
MoveTo(FCX,FCY);
LineTo(FCX+x,FCY-y);
end;
end;
procedure TMymeter.Setbkground;
begin
with Canvas do
begin
pen.Width:=self.Width;
pen.Color:=FBKcolor;
Rectangle(self.ClientRect);
end;
end;
procedure TMymeter.Paint;
begin
inherited;
self.Canvas.Brush.Style:=bsclear;
init;
Setbkground;
PaintCir;
Paintsmalldial;
Paintbigdial;
PaintNeedle(Fvalue);
inherited Paint;
end;
end.

复制代码

仪表盘控件的图例：

逍遥派掌门人的开源控件，欢迎各位社员交作业

kljl2004 · 发表于 2012-6-1 22:45:43

高手，值得学习

bugxiong · 发表于 2012-6-2 12:22:08

太棒了，向你学习

1234567 · 发表于 2012-6-2 13:59:57

先谢谢了

richard9902 · 发表于 2012-6-4 15:08:59

支持，支持，希望做到iocomp那么好啊

逍遥派掌门人 · 发表于 2012-6-5 09:39:35

richard9902:支持，支持，希望做到iocomp那么好啊 (2012-06-04 15:08) 

有更多的人参与进来才能做得更好。

蓝妍志宇 · 发表于 2012-6-5 15:03:17

努力加油

近在眼前 · 发表于 2012-10-12 15:45:27

初来乍到，掌门人可要多指教啊

逍遥派掌门人 · 发表于 2012-10-12 16:36:33

近在眼前:初来乍到，掌门人可要多指教啊  (2012-10-12 15:45) 

欢迎老近！
你是高手了，多发点东西啊。

fireyu · 发表于 2012-12-7 13:25:03

线条能光滑就好了。
颜色有渐变就更好了。
那样我就直接搬运了

		自动登录	找回密码
密码			立即注册（注册审核可向QQ群索取）

[Lazarus实战宝典] 开源控件大家做（4）仪表盘

本帖子中包含更多资源

评分

回 4楼(richard9902) 的帖子

回 7楼(近在眼前) 的帖子

浏览过的版块

[Lazarus实战宝典] 开源控件大家做（4） 仪表盘

本帖子中包含更多资源

评分

回 4楼(richard9902) 的帖子

回 7楼(近在眼前) 的帖子

浏览过的版块

[Lazarus实战宝典] 开源控件大家做（4）仪表盘