rsruler.pas

Usefull Ruler VCL Delphi Component with full source code

unit RsRuler;

//----------------------------------------------------------------------------
//  Delphi 2-7, C++Builder 5 Ruler component, version 4.0, 8 nov 2003
//----------------------------------------------------------------------------
//  (c) 2003 Hans Roos, Roos Software, The Netherlands
//  Website: www.RoosSoftware.nl
//  Email: [e-mail]
//----------------------------------------------------------------------------
//  Features:
//  4 layouts rdTop, rdLeft, rdRight and rdBottom with
//    automatic scale adjustments for each layout
//  Scale: from 1-1000 %
//  Scale numbers can be reversed
//  Units: Inches, Centimetres, Millimetres, Pixels, Meters, Kilometers
//  Automatic calculation of scalenumbers (no overlapping)
//  Sideways text for vertical layouts
//  Flat or 3D appearance
//  TRsRulerCorner: extra component for joining up to 4
//    rulers, can show the unit ('km', 'm', 'cm', 'mm', 'in' or 'px')
//  Font can be changed; sideways fonts only possible if True Type font!
//----------------------------------------------------------------------------
//  See demo project for usage
//  Licence: Freeware! Use in non-commercial or commercial apps
//  Feel free to modify the source for your own needs, but don't remove
//  my name from this file, please.
//  If you find this component useful, please let me know.
//  Don't send money, just be grateful ;)
//----------------------------------------------------------------------------
//  Known issues: None
//  Not yet implemented:
//  Better scale divisions when Inches are used
//  (is it customary to divide inches in 4ths, 8ths, 16ths etc?)
//  Anything YOU can think of; please let me know!! ([e-mail])
//----------------------------------------------------------------------------
//  Revision History
//  v 4.0, 07/11/2003
//    Added property:
//    property ScaleDir: to specify reversed scale numbering. e.g. right-to-left
//    or bottom-to-top
//    property VersionInfo: quick reference to the version of these components
//    Added property values: ruKilo, ruMeter (property Units)
//    Bug-fix: Compiling gave Duplicate Resource errors. Fixed.
//  v.3.0, 07/11/2001
//    Added properties:
//    property Font, ParentFont: user can select any font for scale-drawing.
//    (vertical fonts can only be drawn if True Type font is chosen)
//    property Color, TickColor, Font.Color, ScaleColor
//    property Offset: if you want RsRuler to begin with another number than 0
//    Offset is recalculated when you choose another measuring unit.
//    property ShowMinus: if negative offset, toggle minus sign visibility
//  v.2.0, 31/10/2001
//    Added property value: ruPixel, for measuring pixel units.
//    Added public function Pos2Unit: to calculate unit from mouse position.
//    (see LogoImageMouseMove procedure in demo project for usage)
//  v.1.1, 30/06/2001
//    Added properties :
//    property HairLine, HairLinePos: line on scale, moving with CursorPos.
//    property HairLineStyle: hlsLine (just a hairline)
//      or hlsRect (inverted rectangle).
//  v.1.0, 22/11/2000
//    First release.
//----------------------------------------------------------------------------




interface

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

const
  Kilo: String = 'km';
  Meter: String = 'm';
  Centi: String = 'cm';
  Milli: String = 'mm';
  Inch: String = 'in';
  Pixel: String = 'px';
  None: String = '';
  cVer: String = 'Version 4.0 (c) Roos Software 2003';

type
  TRulerDir = (rdTop, rdLeft, rdRight, rdBottom);
  TRulerScaleDir = (rsdNormal, rsdReverse);
  TRulerUnit = (ruKilo, ruMeter, ruCenti, ruMilli, ruInch, ruPixel, ruNone);
  TCornerPos = (cpLeftTop, cpRightTop, cpLeftBottom, cpRightBottom);
  THairLineStyle = (hlsLine, hlsRect);

  // base class, defines common properties and behaviour of its
  // descendants TRsRuler and TRsRulerCorner
  TRsBaseRuler = class(TGraphicControl)
  private
    fFlat: Boolean;
    fScaleColor: TColor;
    fTickColor: TColor;
    fUnits: TRulerUnit;
    fVersionInfo: String;
    procedure SetFlat(const Value: Boolean);
    procedure SetScaleColor(const Value: TColor);
    procedure SetTickColor(const Value: TColor);
  protected
    LeftSideLF, RightSideLF, NormLF: TLogFont;
    OldFont, NormFont, LeftSideFont, RightSideFont: HFont;
    FirstTime: Boolean;
    procedure Paint; override;
    procedure SetUnit(const Value: TRulerUnit); virtual;
    procedure FontChange(Sender: TObject);
    procedure ChangeFonts;
    procedure DeleteFonts;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Units: TRulerUnit read fUnits write SetUnit;
    property Flat: Boolean read fFlat write SetFlat;
    property ScaleColor: TColor read fScaleColor write SetScaleColor;
    property TickColor: TColor read fTickColor write SetTickColor;
    property VersionInfo: String read fVersionInfo write fVersionInfo;
  end;


  TRsRuler = class(TRsBaseRuler)
  private
    fDirection: TRulerDir;
    fScale: Integer;
    fScaleFactor: Double;
    fAdvance: Double;
    fHairLine: Boolean;
    fHairLinePos: Integer;
    fHairLineStyle: THairLineStyle;
    fOffset: Double;
    fShowMinus: Boolean;
    fScaleDir: TRulerScaleDir;
    procedure SetDirection(const Value: TRulerDir);
    procedure SetScaleDir(const Value: TRulerScaleDir);
    procedure SetScale(const Value: Integer);
    procedure SetHairLine(const Value: Boolean);
    procedure SetHairLinePos(const Value: Integer);
    procedure SetHairLineStyle(const Value: THairLineStyle);
    procedure SetOffset(const Value: Double);
    procedure SetShowMinus(const Value: Boolean);
  protected
    procedure SetUnit(const Value: TRulerUnit); override;
    procedure DrawHairLine;
    procedure CalcAdvance;
    procedure PaintScaleTics;
    procedure PaintScaleLabels;
    procedure Paint; override;
    function ConvertOffset(ToUnit: TRulerUnit): Double;
  public
    constructor Create(AOwner: TComponent); override;
    function Pos2Unit(APos: Integer): Double;
  published
    property VersionInfo;
    property Direction: TRulerDir read fDirection write SetDirection;
    property ScaleDir: TRulerScaleDir read fScaleDir write SetScaleDir;
    property Units;
    property Scale: Integer read fScale write SetScale;
    property HairLine: Boolean read fHairLine write SetHairLine;
    property HairLinePos: Integer read fHairLinePos write SetHairLinePos;
    property HairLineStyle: THairLineStyle read fHairLineStyle write SetHairLineStyle;
    property ScaleColor;
    property TickColor;
    property Offset: Double read fOffset write SetOffset;
    property ShowMinus: Boolean read fShowMinus write SetShowMinus;
    property Align;
    property Font;
    property Color;
    property Height;
    property Width;
    property Visible;
    property Hint;
    property ShowHint;
    property Tag;
    property ParentFont;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
    property OnResize;
  end;

  TRsRulerCorner = class(TRsBaseRuler)
  private
    fPosition: TCornerPos;
    procedure SetPosition(const Value: TCornerPos);
  protected
    fUStr: String;
    procedure Paint; override;
    procedure SetUnit(const Value: TRulerUnit); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property VersionInfo;
    property Align;
    property Position: TCornerPos read fPosition write SetPosition;
    property Flat;
    property ScaleColor;
    property TickColor;
    property Font;
    property Color;
    property Units;
    property Visible;
    property Hint;
    property ShowHint;
    property Tag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
    property OnResize;
  end;

procedure Register;

implementation


procedure Register;
begin
  RegisterComponents('Xtra', [TRsRuler, TRsRulerCorner]);
end;

{ TRsBaseRuler }

constructor TRsBaseRuler.Create(AOwner: TComponent);
begin
  inherited;
  // Initialize vars:
  fFlat := False;
  fUnits := ruCenti;
  fScaleColor := clWindow;
  fTickColor := clWindowText;
  fVersionInfo := cVer;
  FirstTime := True;
  OldFont := 0;
  NormFont := 0;
  LeftSideFont := 0;
  RightSideFont := 0;
  Font.OnChange := FontChange;
end;

procedure TRsBaseRuler.ChangeFonts;
begin
  DeleteFonts;
  // Fill LogFont structures:
  with LeftSideLF do
  begin
    FillChar(LeftSideLF, SizeOf(LeftSideLF), 0);
    lfEscapement := 900;
    lfOrientation := 900;
    StrPCopy(lfFaceName, Font.Name);
    lfHeight := -Font.Height;
    lfWeight := FW_BOLD * Integer(fsBold in Font.Style);
    lfItalic := Integer(fsItalic in Font.Style);
  end;
  with RightSideLF do
  begin
    FillChar(RightSideLF, SizeOf(RightSideLF), 0);
    lfEscapement := 2700;
    lfOrientation := 2700;
    StrPCopy(lfFaceName, Font.Name);
    lfHeight := -Font.Height;
    lfWeight := FW_BOLD * Integer(fsBold in Font.Style);
    lfItalic := Integer(fsItalic in Font.Style);
  end;
  with NormLF do
  begin
    FillChar(NormLF, SizeOf(NormLF), 0);
    StrPCopy(lfFaceName, Font.Name);
    lfHeight := -Font.Height;
    lfWeight := FW_BOLD * Integer(fsBold in Font.Style);
    lfItalic := Integer(fsItalic in Font.Style);
  end;
  Canvas.Font.Color := Font.Color;
  LeftSideFont := CreateFontIndirect(LeftSideLF);
  RightSideFont := CreateFontIndirect(RightSideLF);
  NormFont := CreateFontIndirect(NormLF);
end;

procedure TRsBaseRuler.DeleteFonts;
begin
  if NormFont <> 0 then DeleteObject(NormFont);
  if LeftSideFont <> 0 then DeleteObject(LeftSideFont);
  if RightSideFont <> 0 then DeleteObject(RightSideFont);
end;

destructor TRsBaseRuler.Destroy;
begin
  DeleteFonts;
  inherited;
end;

procedure TRsBaseRuler.FontChange(Sender: TObject);
begin
  ChangeFonts;
  Invalidate;
end;

procedure TRsBaseRuler.Paint;
begin
  Canvas.Brush.Color := Color;
  Canvas.FillRect(Rect(0, 0, Width, Height));
  if FirstTime then
  // setup fonts, cannot be done in Create method,
  // so do it when Ruler gets painted...
  begin
    FirstTime := False;
    ChangeFonts;
    OldFont := Canvas.Font.Handle;
  end;
end;

procedure TRsBaseRuler.SetFlat(const Value: Boolean);
begin
  if Value <> fFlat then
  begin
    fFlat := Value;
    Invalidate;
  end;
end;

procedure TRsBaseRuler.SetScaleColor(const Value: TColor);
begin
  if Value <> fScaleColor then
  begin
    fScaleColor := Value;
    Invalidate;
  end;
end;

procedure TRsBaseRuler.SetTickColor(const Value: TColor);
begin
  if Value <> fTickColor then
  begin
    fTickColor := Value;
    Invalidate;
  end;
end;

procedure TRsBaseRuler.SetUnit(const Value: TRulerUnit);
begin
  // method is empty, see descendants
end;


{ TRsRuler }
constructor TRsRuler.Create(AOwner: TComponent);
begin
  inherited;
  fDirection := rdTop;
  fScaleDir := rsdNormal;
  fScale := 100;
  Height := 33;
  Width := 200;
  fScaleFactor := 1;
  fAdvance := 1;
  fOffset := 0.0;
  fHairLinePos := -1;
  fHairLine := False;
  fHairLineStyle := hlsLine;
  fShowMinus := True;
end;

procedure TRsRuler.CalcAdvance;
begin
  fAdvance := Screen.PixelsPerInch / 10 * fScale / 100;
  if fUnits <> ruInch then fAdvance := fAdvance / 2.54;
  if fUnits = ruPixel then fAdvance := 5 * fScale / 100;
  case fScale of
    1: fScaleFactor := 100;
    2: fScaleFactor := 50;
    3..5: fScaleFactor := 25;
    6..8: fScaleFactor := 20;
    9..12: fScaleFactor := 10;
    13..25: fScaleFactor := 5;
    26..35: fScaleFactor := 4;
    36..50: fScaleFactor := 2;
    51..125: fScaleFactor := 1;
    126..300: fScaleFactor :=  0.5;
    301..400: fScaleFactor := 0.25;
    401..500: fScaleFactor := 0.2;
    501..1000: fScaleFactor := 0.1;
  end;
  fAdvance := fAdvance * fScaleFactor;
end;

procedure TRsRuler.PaintScaleTics;
var
  Pos: Double;
  Start, N, Last, LongTick, Adv: Integer;
begin
  if (fDirection = rdTop) or (fDirection = rdBottom) then Last := Width else Last := Height;
  Start := 0;
  Adv := 1;
  if fScaleDir = rsdReverse then
  begin
    Start := Last;
    Adv := -1;
  end;
  Pos := 0;
  N := 0;
  Canvas.Pen.Color := fTickColor;
  while Pos < Last do with Canvas do
  begin
    LongTick := 2 * (3 + Integer(N mod 5 = 0));
    if (fDirection = rdTop) or (fDirection = rdBottom) then
    begin
      if fDirection = rdTop then
      begin
        MoveTo(Start + Adv * Trunc(Pos), Height - 1);
        LineTo(Start + Adv * Trunc(Pos), Height - LongTick);
      end;
      if fDirection = rdBottom then
      begin