1 有标尺 ( 如图 100us -- 1000us ) 2 在标尺上面有 两个 游标 M1 , M2 (游标)。 3 移动 M1 , M2 ,能计算出移动的位置。 4 此控件与 TrackBar 应该相似,但 TrackBar 控件,只能移动一个游标。
1 有标尺 ( 如图 100us -- 1000us ) 2 在标尺上面有 两个 游标 M1 , M2 (游标)。 3 移动 M1 , M2 ,能计算出移动的位置。 4 此控件与 TrackBar 应该相似,但 TrackBar 控件,只能移动一个游标。
TfrxRuler = class(TPanel)
private
FOffset: Integer;
FScale: Extended;
FStart: Integer;
FUnits: TfrxRulerUnits;
FPosition: Extended;
FSize: Integer;
procedure SetOffset(const Value: Integer);
procedure SetScale(const Value: Extended);
procedure SetStart(const Value: Integer);
procedure SetUnits(const Value: TfrxRulerUnits);
procedure SetPosition(const Value: Extended);
procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
procedure SetSize(const Value: Integer);
public
constructor Create(AOwner: TComponent); override;
procedure Paint; override;
published
property Offset: Integer read FOffset write SetOffset;
property Scale: Extended read FScale write SetScale;
property Start: Integer read FStart write SetStart;
property Units: TfrxRulerUnits read FUnits write SetUnits default ruPixels;
property Position: Extended read FPosition write SetPosition;
property Size: Integer read FSize write SetSize;
end;{ TfrxRuler }constructor TfrxRuler.Create(AOwner: TComponent);
begin
inherited;
FScale := 1;
DoubleBuffered := True;
end;procedure TfrxRuler.WMEraseBackground(var Message: TMessage);
begin
//
end;procedure TfrxRuler.Paint;
var
fh, oldfh: HFont;
sz: Integer; function CreateRotatedFont(Font: TFont): HFont;
var
F: TLogFont;
begin
GetObject(Font.Handle, SizeOf(TLogFont), @F);
F.lfEscapement := 90 * 10;
F.lfOrientation := 90 * 10;
Result := CreateFontIndirect(F);
end; procedure Line(x, y, dx, dy: Integer);
begin
Canvas.MoveTo(x, y);
Canvas.LineTo(x + dx, y + dy);
end; procedure DrawLines;
var
i, dx, maxi: Extended;
i1, h, w, w5, w10, maxw, ofs: Integer;
s: String;
begin
with Canvas do
begin
Pen.Color := clBlack;
Brush.Style := bsClear;
w5 := 5;
w10 := 10;
if FUnits = ruCM then
dx := fr01cm * FScale
else if FUnits = ruInches then
dx := fr01in * FScale
else if FUnits = ruChars then
begin
if Align = alLeft then
dx := fr1CharY * FScale / 10 else
dx := fr1CharX * FScale / 10
end
else
begin
dx := FScale;
w5 := 50;
w10 := 100;
end; if FSize = 0 then
begin
if Align = alLeft then
maxi := Height + FStart else
maxi := Width + FStart;
end
else
maxi := FSize; if FUnits = ruPixels then
s := IntToStr(FStart + Round(maxi / dx)) else
s := IntToStr((FStart + Round(maxi / dx)) div 10); maxw := TextWidth(s);
ofs := FOffset - FStart;
if FUnits = ruChars then
begin
if Align = alLeft then
Inc(ofs, Round(fr1CharY * FScale / 2)) else
Inc(ofs, Round(fr1CharX * FScale / 2))
end; i := 0;
i1 := 0;
while i < maxi do
begin
h := 0;
if i1 = 0 then
h := 0
else if i1 mod w10 = 0 then
h := 6
else if i1 mod w5 = 0 then
h := 4
else if FUnits <> ruPixels then
h := 2; if (h = 2) and (dx * w10 < 41) then
h := 0;
if (h = 4) and (dx * w10 < 21) then
h := 0; w := 0;
if h = 6 then
begin
if maxw > dx * w10 * 1.5 then
w := w10 * 4
else if maxw > dx * w10 * 0.7 then
w := w10 * 2
else
w := w10;
end; if FUnits = ruPixels then
s := IntToStr(i1) else
s := IntToStr(i1 div 10); if (w <> 0) and (i1 mod w = 0) and (ofs + i >= FOffset) then
if Align = alLeft then
TextOut(Width - TextHeight(s) - 6, ofs + Round(i) + TextWidth(s) div 2 + 1, s) else
TextOut(ofs + Round(i) - TextWidth(s) div 2 + 1, 4, s)
else if (h <> 0) and (ofs + i >= FOffset) then
if Align = alLeft then
Line(3 + (13 - h) div 2, ofs + Round(i), h, 0) else
Line(ofs + Round(i), 3 + (13 - h) div 2, 0, h); i := i + dx;
Inc(i1);
end; i := FPosition * dx;
if FUnits <> ruPixels then
i := i * 10;
if ofs + i >= FOffset then
if Align = alLeft then
Line(3, ofs + Round(i), 13, 0) else
Line(ofs + Round(i), 3, 0, 13);
end;
end;begin
fh := 0; oldfh := 0;
with Canvas do
begin
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
FillRect(Rect(0, 0, Width, Height));
Brush.Color := clWindow; Font.Name := 'Arial';
Font.Size := 7;
if Align = alLeft then
begin
if FSize = 0 then
sz := Height
else
sz := FSize + FOffset;
FillRect(Rect(3, FOffset, Width - 5, sz));
fh := CreateRotatedFont(Font);
oldfh := SelectObject(Handle, fh);
end
else
begin
if FSize = 0 then
sz := Width
else
sz := FSize + FOffset;
FillRect(Rect(FOffset, 3, sz, Height - 5));
end;
end; DrawLines; if Align = alLeft then
begin
SelectObject(Canvas.Handle, oldfh);
DeleteObject(fh);
end;
end;procedure TfrxRuler.SetOffset(const Value: Integer);
begin
FOffset := Value;
Invalidate;
end;procedure TfrxRuler.SetPosition(const Value: Extended);
begin
FPosition := Value;
Invalidate;
end;procedure TfrxRuler.SetScale(const Value: Extended);
begin
FScale := Value;
Invalidate;
end;procedure TfrxRuler.SetStart(const Value: Integer);
begin
FStart := Value;
Invalidate;
end;procedure TfrxRuler.SetUnits(const Value: TfrxRulerUnits);
begin
FUnits := Value;
Invalidate;
end;procedure TfrxRuler.SetSize(const Value: Integer);
begin
FSize := Value;
Invalidate;
end;