horizruler.pas

一个尺子的源码。（横向）

{
 *************************************************************************
                      HorizRuler component
                        ver 1.0 Freeware
                           for Delphi 5 ( not tested on other)
                      Author Tomasz Grecznaik ( Gryku)
                        mail: [e-mail]
                          Wroclaw 14.12.2000
                       Wroclaw University of Technology
  *************************************************************************
}
unit HorizRuler;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls, StdCtrls, Forms;


type
  TPlace = (plTop, plBottom);

  THorizRuler = class(TPanel)
  private

    FOnPaint: TNotifyEvent;
    FUsePanelStyle: Boolean;
    FscalaColor: Tcolor;
    FscalaFactor: Integer;
    FscalaFontSize: integer;
    FscalaOffset: integer;
    FScalaTextIncrement: real;
    FScalaShowText: boolean;
    FScalaEdge: Tplace;
    FShowUnit: boolean;
    FTextUnit: string;
  protected

    procedure Paint; override;
    procedure SetUsePanelStyle(Value: Boolean);
    procedure Paintscala(obj: TObject);
    procedure SetscalaFactor(value: integer);
    procedure SetscalaColor(value: Tcolor);
    procedure SetscalaOffset(value: integer);
    procedure SetscalaTextIncrement(value: real);
    procedure SetScalaShowText(value: boolean);
    procedure SetScalaEdge(value: TPlace);
    procedure SetShowUnit(value: boolean);
    procedure SetTextUnit(value: string);
    procedure SetScalaFontSize(value: integer);
    procedure PaintUnit;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property Canvas;
    procedure Clear;
    procedure PaintBorder;

  public
    constructor create(Owner: TComponent); override;
  published

    property ScalaShowText: boolean read FScalaShowText write SetScalaShowText default true;
    property ScalaFactor: Integer read FscalaFactor write SetscalaFactor default 2;
    property ScalaColor: Tcolor read FscalaColor write SetscalaColor default clblack;
    property ScalaFontSize: integer read FscalaFontSize write SetscalaFontSize;
    property ScalaOffset: Integer read FscalaOffset write SetscalaOffset default 100;
    property ScalaTextIncrement: real read FscalaTextIncrement write SetScalaTextIncrement;
    property ScalaEdgePos: tplace read Fscalaedge write SetscalaEdge default plTop;
    property ShowUnit: boolean read FShowUnit write SetShowUnit default true;
    property TextUnit: string read FTextUnit write SetTextUnit;
    property UsePanelStyle: Boolean read FUsePanelStyle write SetUsePanelStyle default true;
  end;

procedure Register;

implementation

procedure THorizRuler.Clear;
var r: Trect;
begin
  r.Top := 1;
  r.left := 1;
  r.Right := width - 1;
  r.Bottom := height - 1;
  canvas.brush.Color := color; //cl3dlight;
  canvas.brush.style := bssolid;
  canvas.fillrect(r);
end;

constructor THorizRuler.create(Owner: TComponent);
begin
  inherited create(Owner);

  parent := owner as TWinControl;
  usepanelstyle := true;
  top := 100;
  left := 55;
  height := 22;
  FscalaFactor := 2;

  FscalaFontSize := 6;
  FscalaOffset := 100;
  FScalaTextIncrement := 1;
  FscalaShowtext := true;
  FscalaEdge := plTop;
  FShowUnit := true;
  Ftextunit := 'mm';
  onpaint := paintscala;
  paintscala(self);
end;

procedure THorizRuler.Paint;
begin
  if FUsePanelStyle then inherited Paint;
  if Assigned(FOnPaint) then FOnPaint(Self);
end;

procedure THorizRuler.PaintBorder;
begin
  canvas.Pen.Color := clBtnHighLight;
  canvas.moveto(0, 0);
  canvas.lineto(0, height);
  canvas.Pen.color := clBtnShadow;
  canvas.MoveTo(width - 1, 0);
  canvas.lineto(width - 1, height);
end;

procedure THorizRuler.Paintscala(obj: TObject);
var i, j: integer;
  scala: integer;
  x: integer;
  x2: integer;
  y, y1: integer;
  s, k: integer;
begin
  clear;
  canvas.Pen.color := FscalaColor;
  canvas.Font.Name := 'arial';
  canvas.Font.size := FscalaFontSize;
  scala := 10 * FscalaFactor;
  if FscalaEdge = plTop then
  begin
    y := 1; y1 := 10; s := 1; k := 1;
  end
  else
  begin
    y := height - 2; y1 := height - 10; s := -1; k := -11;
  end;

  for i := 0 to ((width - FscalaOffset) div scala) do
  begin
    x := (i * scala);
    canvas.moveto(x + FscalaOffset, y);
    canvas.LineTo(x + FscalaOffset, y1);

    if FScalaShowText then
      canvas.TextOut(x - 2 + FscalaOffset, y1 + k, floattostr(i * FScalaTextIncrement));

    canvas.moveto(x + (scala div 2) + FscalaOffset, y);
    canvas.LineTo(x + (scala div 2) + FscalaOffset, y1 - (3 * s));

    for j := 0 to 10 do
    begin
      x2 := (j * FscalaFactor);
      canvas.moveto(x + x2 + FscalaOffset, y);
      canvas.lineto(x + x2 + FscalaOffset, y1 - (5 * s));
    end;
  end;
  for i := 0 downto -Fscalaoffset + 1 do
  begin
    x := (i * scala);
    canvas.moveto(x + FscalaOffset, y);
    canvas.LineTo(x + FscalaOffset, y1);

    if FScalaShowText then
      canvas.TextOut(x - 2 + FscalaOffset, y1 + k, floattostr(i * FScalaTextIncrement));

    canvas.moveto(x + FscalaOffset + (scala div 2), y);
    canvas.LineTo(x + FscalaOffset + (scala div 2), y1 - (3 * s));

    for j := 0 to 10 do
    begin
      x2 := (j * FscalaFactor);
      canvas.moveto(x + x2 + FscalaOffset, y);
      canvas.lineto(x + x2 + FscalaOffset, y1 - (5 * s));
    end;
  end;
  if FshowUnit then
    canvas.textout(width - canvas.textwidth(FtextUnit) - 4, y1 + k, FTextUnit);

  paintborder;
end;

procedure THorizRuler.PaintUnit;
var w: integer;
begin

end;

procedure THorizRuler.SetscalaColor(value: Tcolor);
begin
  FscalaColor := value;
  paintscala(self)
end;

procedure THorizRuler.SetScalaEdge(value: TPlace);
begin
  FscalaEdge := value;
  paintscala(self)
end;

procedure THorizRuler.SetscalaFactor(value: integer);
begin
  FscalaFactor := value;
  paintscala(self)
end;


procedure THorizRuler.SetScalaFontSize(value: integer);
begin
  FScalaFontSize := value;
  paintscala(self);
end;

procedure THorizRuler.SetscalaOffset(value: integer);
begin
  FscalaOffset := value;
  paintscala(self)
end;

procedure THorizRuler.SetScalaShowText(value: boolean);
begin
  FScalaShowText := value;
  paintscala(self)
end;

procedure THorizRuler.SetScalaTextIncrement(value: real);
begin
  FScalaTextIncrement := value;
  paintscala(self)
end;

procedure THorizRuler.SetShowUnit;
begin
  FShowunit := value;
  paintscala(self)
end;

procedure THorizRuler.SetTextUnit;
begin
  FTextUnit := Value;
  paintscala(self)
end;

procedure THorizRuler.SetUsePanelStyle(Value: Boolean);
begin
  FUsePanelStyle := Value;
  RePaint;
end;

procedure Register;
begin
  RegisterComponents('Freeware', [THorizRuler]);
end;

end.