移植的标尺控件

逍遥派掌门人 · 发表于 2012-6-8 17:37:59

完整代码：

unit ruler;
{$mode objfpc}{$H+}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,LResources;
type
TTicksKind = (tkHorizontal, tkVertical);
TTicksStyle = (tkTopLeft, tkBottomRight);
TTicksAlign = (tkUpLeft, tkDwonRight);
Truler = class(TGraphicControl)
private
{ Private declarations }
FTicksColor1: TColor;
FTicksColor2: TColor;
FTicksColor3: TColor;
FBKColor: TColor;
FDialColor1: TColor;
FDialColor2: TColor;
FDialColor3: TColor;
FTicksNum: Integer;
FMaxVal: Integer;
FMinVal: Integer;
FSubDialNum: Integer;
FShowSubDial: Boolean;
FTicksLength: Integer;
FDialLength: Integer;
FPercent1: Integer;
FPercent2: Integer;
FKind: TTicksKind;
FStyle: TTicksStyle;
FTicksAlign : TTicksAlign;
FBorder: integer;
TicksStep: Integer;
FShowSign: Boolean;
procedure SetBKColor(Value: TColor);
procedure SetTicksNum(Value: Integer);
procedure SetTicksColor1(Value: TColor);
procedure SetMaxVal(const Value: Integer);
procedure SetMinVal(const Value: Integer);
procedure SetSubDialNum(const Value: Integer);
procedure SetShowSubDial(Value: Boolean);
procedure SetDialLength(const Value: Integer);
procedure SetTicksLength(const Value: Integer);
procedure SetDialColor1(const Value: TColor);
function GetTransparent: Boolean;
procedure SetTransparent(const Value: Boolean);
procedure SetPercent1(const Value: integer);
procedure SetPercent2(const Value: integer);
procedure SetDialColor2(const Value: TColor);
procedure SetDialColor3(const Value: TColor);
procedure SetTicksColor2(const Value: TColor);
procedure SetTicksColor3(const Value: TColor);
procedure SetKind(const Value: TTicksKind);
procedure SetStyle(const Value: TTicksStyle);
procedure SetTicksAlign(const Value: TTicksAlign);
procedure SetBorder(const Value: Integer);
procedure SetShowSign(const Value: Boolean);
procedure ChangeColor(Value: Integer);
protected
{ Protected declarations }
procedure Paint; override;
procedure DrawBK;
procedure DrawVTicks;
procedure DrawHTicks;
public
{ Public declarations }
constructor Create(AOwner:TComponent); override;
published
{ Published declarations }
property BKColor: TColor read FBKColor write SetBKColor default clBlack;
property TicksNum: Integer read FTicksNum write SetTicksNum default 10;
property MaxVal: Integer read FMaxVal write SetMaxVal default 100;
property MinVal: Integer read FMinVal write SetMinVal default 0;
property TicksColor1: TColor read FTicksColor1 write SetTicksColor1 default clLime;
property TicksColor2: TColor read FTicksColor2 write SetTicksColor2 default clYellow;
property TicksColor3: TColor read FTicksColor3 write SetTicksColor3 default clRed;
property SubDialNum: Integer read FSubDialNum write SetSubDialNum default 5;
property ShowSubDial: Boolean read FShowSubDial write SetShowSubDial default true;
property TicksLength: Integer read FTicksLength write SetTicksLength default 6;
property DialLength: Integer read FDialLength write SetDialLength default 3;
property DialColor1: TColor read FDialColor1 write SetDialColor1 default clWhite;
property DialColor2: TColor read FDialColor2 write SetDialColor2 default clWhite;
property DialColor3: TColor read FDialColor3 write SetDialColor3 default clWhite;
property Transparent: Boolean read GetTransparent write SetTransparent default false;
property Percent1: integer read FPercent1 write SetPercent1 default 40;
property Percent2: integer read FPercent2 write SetPercent2 default 60;
property Kind: TTicksKind read FKind write SetKind default tkVertical;
property Style: TTicksStyle read FStyle write SetStyle default tkTopLeft;
property TicksAlign: TTicksAlign read FTicksAlign write SetTicksAlign default tkUpLeft;
Property Font;
property Border: Integer read FBorder write SetBorder default 10;
property ShowSign: Boolean read FShowSign write SetShowSign default false;
end;
procedure Register;
implementation
procedure Register;
begin
{$I ruler_icon.lrs}
RegisterComponents('fpccn', [Truler]);
end;
{ Truler }
procedure Truler.ChangeColor(Value: Integer);
var
PNum1,PNum2 : Integer;
begin
if Fkind = tkVertical then
begin
PNum1 := FBorder + Round((Height - FBorder * 2) / 100 * FPercent1);
PNum2 := FBorder + Round((Height - FBorder * 2) / 100 * (FPercent1 + FPercent2));
end
else
begin
PNum1 := FBorder + Round((Width - FBorder * 2) / 100 * FPercent1);
PNum2 := FBorder + Round((Width - FBorder * 2) / 100 * (FPercent1 + FPercent2));
end;
if Value <= PNum1 then
begin
Canvas.Font.Color := FTicksColor1;
Canvas.Pen.Color := FDialColor1;
exit;
end;
if (Value > PNum1) and (Value <= PNum2) then
begin
Canvas.Font.Color := FTicksColor2;
Canvas.Pen.Color := FDialColor2;
exit;
end;
if (Value > PNum2) then
begin
Canvas.Font.Color := FTicksColor3;
Canvas.Pen.Color := FDialColor3;
exit;
end;
end;
constructor Truler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque, csReplicatable];
Height := 200;
Width := 25;
FBKColor := clBlack;
TicksNum := 10;
FMaxVal := 100;
FminVal := 0;
FTicksColor1 := clLime;
FTicksColor2 := clYellow;
FTicksColor3 := clRed;
FSubDialNum := 5;
FShowSubDial := true;
FTicksLength := 6;
FDialLength := 3;
FDialColor1 := clWhite;
FDialColor2 := clWhite;
FDialColor3 := clWhite;
FPercent1 := 40;
FPercent2 := 60;
FKind := tkVertical;
FStyle := tkTopLeft;
FTicksAlign := tkUpLeft;
FBorder := 10;
FShowSign := false;
end;
procedure Truler.DrawBK;
begin
With Canvas do
begin
if not Transparent then
begin
Brush.Style := bsSolid;
Brush.Color := fBkColor;
FillRect(ClientRect);
end
else
begin
Brush.Style := bsClear;
end;
Pen.Style := psSolid;
Pen.Color := FBKColor;
end;
end;
procedure Truler.DrawHTicks;
Var
i, n, DPos: Integer;
CapStr: String;
begin
TicksStep := (Width - FBorder * 2) Div TicksNum;
Canvas.Font := Font;
With Canvas do
begin
for i := 0 to FTicksNum do
begin
if Style = tkBottomRight then
DPos := Round(FMaxVal - (FMaxVal - FMinVal)/ FTicksNum* i)
else
DPos := Round(FMinVal + (FMaxVal - FMinVal)/ FTicksNum* i);
CapStr := IntToStr(DPos);
if FShowSign and (DPos > 0) then
Capstr := '+'+ Capstr;
ChangeColor(i * TicksStep + FBorder);
if FTicksAlign = tkUpLeft then
begin
TextOut(i * TicksStep - TextWidth(CapStr) div 2+ FBorder, TicksLength, CapStr);
MoveTo(i * TicksStep + FBorder,0);
LineTo(i *TicksStep + FBorder,FTicksLength);
If (i < FTicksNum) and FShowSubDial then
For n := 1 to FSubDialNum do
begin
ChangeColor(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
MoveTo(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n),0);
LineTo(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n),FDialLength);
end;
end
else
begin
TextOut(i * TicksStep - TextWidth(CapStr) div 2+ FBorder,Height - FTicksLength - TextHeight(CapStr) - 1, CapStr);
MoveTo(i * TicksStep + FBorder,Height - FTicksLength);
LineTo(i *TicksStep + FBorder,Height);
If (i < FTicksNum) and FShowSubDial then
For n := 1 to FSubDialNum do
begin
ChangeColor(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
MoveTo(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n),Height - FDialLength);
LineTo(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n),Height);
end;
end;
end;
end;
end;
procedure Truler.DrawVTicks;
Var
i, n, DPos: Integer;
CapStr : String;
begin
TicksStep := (Height - FBorder * 2) Div TicksNum;
Canvas.Font := Font;
With Canvas do
begin
for i := 0 to FTicksNum do
begin
if Style = tkBottomRight then
DPos := Round(FMaxVal - (FMaxVal - FMinVal)/ FTicksNum* i)
else
DPos := Round(FMinVal + (FMaxVal - FMinVal)/ FTicksNum* i);
ChangeColor(i * TicksStep + FBorder);
CapStr := IntToStr(DPos);
if FShowSign and (DPos > 0) then
Capstr := '+'+ Capstr;
if FTicksAlign = tkUpLeft then
begin
TextOut(FTicksLength, i * TicksStep - TextHeight(CapStr) Div 2 + FBorder, CapStr);
MoveTo(0,i * TicksStep + FBorder);
LineTo(FTicksLength,i *TicksStep + FBorder);
If (i < FTicksNum) and FShowSubDial then
For n := 1 to FSubDialNum do
begin
ChangeColor(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
MoveTo(0,i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
LineTo(FDialLength,i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
end;
end
else
begin
TextOut(Width - FTicksLength - TextWidth(CapStr)-1, i * TicksStep - TextHeight(CapStr) Div 2 + FBorder, CapStr);
MoveTo(Width - FTicksLength,i * TicksStep + FBorder);
LineTo(Width,i *TicksStep + FBorder);
If (i < FTicksNum) and FShowSubDial then
For n := 1 to FSubDialNum do
begin
ChangeColor(i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
MoveTo(Width - FDialLength,i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
LineTo(Width,i * TicksStep + FBorder + Round(TicksStep/SubDialNum*n));
end;
end;
end;
end;
end;
function Truler.GetTransparent: Boolean;
begin
Result := not (csOpaque in ControlStyle);
end;
procedure Truler.Paint;
begin
DrawBK;
if FKind = tkHorizontal then
DrawHTicks
else
DrawVTicks;
end;
procedure Truler.SetBKColor(Value: TColor);
begin
if FBKColor <> Value then
begin
FBKColor := Value;
Invalidate;
end;
end;
procedure Truler.SetBorder(const Value: Integer);
begin
if FBorder <> Value then
begin
FBorder := Value;
Invalidate;
end;
end;
procedure Truler.SetDialColor1(const Value: TColor);
begin
if FDialColor1 <> Value then
begin
FDialColor1 := Value;
Invalidate;
end;
end;
procedure Truler.SetDialColor2(const Value: TColor);
begin
if FDialColor2 <> Value then
begin
FDialColor2 := Value;
Invalidate;
end;
end;
procedure Truler.SetDialColor3(const Value: TColor);
begin
if FDialColor3 <> Value then
begin
FDialColor3 := Value;
Invalidate;
end;
end;
procedure Truler.SetDialLength(const Value: Integer);
begin
If FdialLength <> Value then
begin
FDialLength := Value;
Invalidate;
end;
end;
procedure Truler.SetKind(const Value: TTicksKind);
begin
if FKind <> Value then
begin
FKind := Value;
if not (csLoading in ComponentState) then SetBounds(Left, Top, Height, Width);
Invalidate;
end;
end;
procedure Truler.SetMaxVal(const Value: Integer);
begin
if (FMaxVal <> Value) and (Value > MinVal) then
begin
FMaxVal := Value;
Invalidate;
end;
end;
procedure Truler.SetMinVal(const Value: Integer);
begin
if (FMinVal <> Value) and (Value < MaxVal) then
begin
FMinVal := Value;
Invalidate;
end;
end;
procedure Truler.SetPercent1(const Value: integer);
begin
if FPercent1 <> Value then
begin
FPercent1 := Value;
Invalidate;
end;
end;
procedure Truler.SetPercent2(const Value: integer);
begin
if FPercent2 <> Value then
begin
FPercent2 := Value;
Invalidate;
end;
end;
procedure Truler.SetShowSign(const Value: Boolean);
begin
if FShowSign <> Value then
begin
FShowSign := Value;
Invalidate;
end;
end;
procedure Truler.SetShowSubDial(Value: Boolean);
begin
if FShowSubDial <> Value then
begin
FShowSubDial := Value;
Invalidate;
end;
end;
procedure Truler.SetStyle(const Value: TTicksStyle);
begin
if FStyle <> Value then
begin
FStyle := Value;
Invalidate;
end;
end;
procedure Truler.SetSubDialNum(const Value: Integer);
begin
if FSubDialNum <> Value then
begin
FSubDialNum := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksAlign(const Value: TTicksAlign);
begin
if FTicksAlign <> Value then
begin
FTicksAlign := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksColor1(Value: TColor);
begin
if FTicksColor1 <> Value then
begin
FTicksColor1 := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksColor2(const Value: TColor);
begin
if FTicksColor2 <> Value then
begin
FTicksColor2 := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksColor3(const Value: TColor);
begin
if FTicksColor3 <> Value then
begin
FTicksColor3 := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksLength(const Value: Integer);
begin
if FTicksLength <> Value then
begin
FTicksLength := Value;
Invalidate;
end;
end;
procedure Truler.SetTicksNum(Value: Integer);
begin
if FTicksNum <> Value then
begin
FTicksNum := Value;
Invalidate;
end;
end;
procedure Truler.SetTransparent(const Value: Boolean);
begin
if Transparent <> Value then
begin
if Value then
ControlStyle := ControlStyle - [csOpaque] else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
end.

复制代码

效果图：

东兰梦舞 · 发表于 2012-6-9 10:28:09

社区有你更精彩，不加分……

1234567 · 发表于 2012-6-9 13:58:02

谢谢分享,先收藏了!!!!!!!

逍遥派掌门人 · 发表于 2012-6-10 01:28:33

东兰梦舞:社区有你更精彩，不加分…… (2012-06-09 10:28) 

太抠门了。

猫工 · 发表于 2012-6-10 18:57:37

优秀文章，支持！n神马都是浮云！

roolive · 发表于 2012-6-20 20:54:38

好东西。用上了。。。

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

[界面] 移植的标尺控件

本帖子中包含更多资源

评分

回 1楼(东兰梦舞) 的帖子

浏览过的版块