rsruler.pas

Usefull Ruler VCL Delphi Component with full source code

        MoveTo(Start + Adv * Trunc(Pos), 0);
        LineTo(Start + Adv * Trunc(Pos), LongTick - 1);
      end;
    end else
    begin
      if fDirection = rdLeft then
      begin
        MoveTo(Width - 1, Start + Adv * Trunc(Pos));
        LineTo(Width - LongTick, Start + Adv * Trunc(Pos));
      end;
      if fDirection = rdRight then
      begin
        MoveTo(0, Start + Adv * Trunc(Pos));
        LineTo(LongTick - 1, Start + Adv * Trunc(Pos));
      end;
    end;
    Inc(N);
    Pos := Pos + 2 * fAdvance; // always advance two units to next ticmark
  end;
end;

procedure TRsRuler.PaintScaleLabels;
var
  Pos, Number, ScaleN: Double;
  Start, N, Last, Wi, He, Center, Adv: Integer;
  S: String;
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 := Font.Color;
  while Pos < Last do with Canvas do
  begin
    Number := fScaleFactor * N / 10;
    if Units = ruMilli then Number := 10 * Number;
    if Units = ruMeter then Number := Number / 100;
    if Units = ruKilo then Number := Number / 100000;
    if Units = ruPixel then Number := 50 * Number;
    ScaleN := Number + fOffset;
    if fUnits = ruPixel then ScaleN := Round(ScaleN);
    if fUnits = ruInch then ScaleN := Round(100 * ScaleN) / 100;
    if fShowMinus then S := FormatFloat('0.##', ScaleN) else S := FormatFloat('0.##', Abs(ScaleN));
    Wi := TextWidth(S);
    He := TextHeight(S);
    if (fDirection = rdTop) or (fDirection = rdBottom) then
    begin
      MoveTo(Start + Adv * Trunc(Pos), 1);  // only Pos is important
      if fDirection = rdTop then
      begin
        // draw number..
        if (N <> 0) and (N mod 10 = 0) then TextOut(PenPos.X - Wi div 2, Height - He - 8, S)
        else if (N <> 0) and (N mod 5 = 0) then
        begin
          // or just a notch
          Center := Height + (-(He + 6) - 8) div 2;
          MoveTo(Start + Adv * Trunc(Pos), Center - 1);
          LineTo(Start + Adv * Trunc(Pos), Center + 2);
        end;
      end;
      if fDirection = rdBottom then
      begin
        // draw number..
        if (N <> 0) and (N mod 10 = 0) then TextOut(PenPos.X - Wi div 2, 8, S)
        else if (N <> 0) and (N mod 5 = 0) then
        begin
          // or just a notch
          Center := ((He + 6) + 8) div 2;
          MoveTo(Start + Adv * Trunc(Pos), Center - 2);
          LineTo(Start + Adv * Trunc(Pos), Center + 1);
        end;
      end;
    end else
    begin
      MoveTo(1, Start + Adv * Trunc(Pos));
      if fDirection = rdLeft then
      begin
        // draw number..
        if (N <> 0) and (N mod 10 = 0) then TextOut(Width - He - 7, PenPos.Y + Wi div 2, S)
        else if (N <> 0) and (N mod 5 = 0) then
        begin
          // or just a notch
          Center := Width + (-(He + 6) - 8) div 2;
          MoveTo(Center - 1, Start + Adv * Trunc(Pos));
          LineTo(Center + 2, Start + Adv * Trunc(Pos));
        end;
      end;
      if fDirection = rdRight then
      begin
        if (N <> 0) and (N mod 10 = 0) then TextOut(He + 7, PenPos.Y - Wi div 2, S)
        else if (N <> 0) and (N mod 5 = 0) then
        begin
          // or just a notch
          Center := ((He + 6) + 8) div 2;
          MoveTo(Center - 2, Start + Adv * Trunc(Pos));
          LineTo(Center + 1, Start + Adv * Trunc(Pos));
        end;
      end;
    end;
    Inc(N);
    Pos := Pos + fAdvance;
  end;
end;

procedure TRsRuler.Paint;
var
  Rect: TRect;
  He, d: Integer;
begin
  inherited;
  fHairLinePos := -1;
  Rect := ClientRect;
  if Not Flat then DrawEdge(Canvas.Handle, Rect, EDGE_RAISED, BF_RECT);
  d := 2 - Integer(Flat);
  SelectObject(Canvas.Handle, NormFont);
  He := Canvas.TextHeight('0') + 6;
  if (fDirection = rdTop) or (fDirection = rdBottom) then
  begin
    if fDirection = rdTop then SetRect(Rect, d, Height - He - 1, Width - d, Height - 8);
    if (fDirection = rdBottom) then SetRect(Rect, d, 8, Width - d, He + 1);
    SelectObject(Canvas.Handle, NormFont);
  end else
  begin
    if fDirection = rdLeft then
    begin
      SetRect(Rect, Width - He, d, Width - 8, Height - d);
      SelectObject(Canvas.Handle, LeftSideFont);
    end;
    if fDirection = rdRight then
    begin
      SetRect(Rect, He, d, 8, Height - d);
      SelectObject(Canvas.Handle, RightSideFont);
    end;
  end;
  Canvas.Brush.Color := fScaleColor;
  Canvas.FillRect(Rect);
  CalcAdvance;
  SetBKMode(Canvas.Handle, TRANSPARENT);
  PaintScaleTics;
  PaintScaleLabels;
  SetBKMode(Canvas.Handle, OPAQUE);
  SelectObject(Canvas.Handle, OldFont);
end;

procedure TRsRuler.SetDirection(const Value: TRulerDir);
var
  Dim: TPoint;
  OldDir: TRulerDir;
begin
  OldDir := fDirection;
  if Value <> fDirection then
  begin
    if ((OldDir = rdTop) or (OldDir = rdBottom)) and ((Value = rdLeft) or (Value = rdRight))
    or ((OldDir = rdLeft) or (OldDir = rdRight)) and ((Value = rdTop) or (Value = rdBottom)) then
    begin
      Dim := Point(Width, Height);
      Width := Dim.Y;
      Height := Dim.X;
    end;
    fDirection := Value;
    Invalidate;
  end;
end;

procedure TRsRuler.SetScaleDir(const Value: TRulerScaleDir);
begin
  if (Value <> fScaleDir) then
  begin
    fScaleDir := Value;
    Invalidate;
  end;
end;

procedure TRsRuler.SetScale(const Value: Integer);
begin
  if (Value <> fScale) and (Value > 0) then
  begin
    fScale := Value;
    Invalidate;
  end;
end;

procedure TRsRuler.SetUnit(const Value: TRulerUnit);
begin
  if Value <> fUnits then
  begin
    fOffSet := ConvertOffset(Value);
    fUnits := Value;
    Invalidate;
  end;
end;


procedure TRsRuler.SetHairLine(const Value: Boolean);
begin
  if Value <> fHairLine then
  begin
    fHairLine := Value;
    Invalidate;
  end;
end;

procedure TRsRuler.SetHairLinePos(const Value: Integer);
begin
  if Value <> fHairLinePos then
  begin
    DrawHairLine; // erase old position
    fHairLinePos := Value;
    DrawHairLine; // draw new position
  end;
end;

procedure TRsRuler.DrawHairLine;
var
  He: Integer;
begin
  if fHairLine then if fHairLinePos <> -1 then with Canvas do
  begin
    Pen.Mode := pmNotXOr;
    SelectObject(Canvas.Handle, NormFont);
    He := TextHeight('0') + 6;
    SelectObject(Canvas.Handle, OldFont);
    if fDirection = rdTop then
    begin
      if fHairLineStyle = hlsLine
      then InvertRect(Canvas.Handle, Rect(fHairLinePos - 1, Height - He - 1, fHairLinePos, Height - 8))
      else
      if fScaleDir = rsdNormal then InvertRect(Canvas.Handle, Rect(1, Height - He - 1, fHairLinePos, Height - 8))
      else InvertRect(Canvas.Handle, Rect(Width, Height - He - 1, fHairLinePos, Height - 8));
    end;
    if fDirection = rdBottom then
    begin
      if fHairLineStyle = hlsLine
      then InvertRect(Canvas.Handle, Rect(fHairLinePos - 1, 8, fHairLinePos, He))
      else
      if fScaleDir = rsdNormal
      then InvertRect(Canvas.Handle, Rect(1, 8, fHairLinePos, He + 1))
      else InvertRect(Canvas.Handle, Rect(Width, 8, fHairLinePos, He + 1));
    end;
    if fDirection = rdLeft then
    begin
      if fHairLineStyle = hlsLine
      then InvertRect(Canvas.Handle, Rect(Width - He, fHairLinePos - 1, Width - 8, fHairLinePos))
      else
      if fScaleDir = rsdNormal then InvertRect(Canvas.Handle, Rect(Width - He, 1, Width - 8, fHairLinePos))
      else InvertRect(Canvas.Handle, Rect(Width - He, Height, Width - 8, fHairLinePos));
    end;
    if fDirection = rdRight then
    begin
      if fHairLineStyle = hlsLine
      then InvertRect(Canvas.Handle, Rect(8, fHairLinePos - 1, He, fHairLinePos))
      else
      if fScaleDir = rsdNormal then InvertRect(Canvas.Handle, Rect(8, 1, He, fHairLinePos))
      else InvertRect(Canvas.Handle, Rect(8, Height, He, fHairLinePos));
    end;
    Pen.Mode := pmCopy;
  end;
end;

procedure TRsRuler.SetHairLineStyle(const Value: THairLineStyle);
begin
  if Value <> fHairLineStyle then
  begin
    fHairLineStyle := Value;
    Invalidate;
  end;
end;

function TRsRuler.Pos2Unit(APos: Integer): Double;
var
  ThePos, EndPos: Integer;
begin
  ThePos := APos;
  if (fDirection = rdTop) or (fDirection = rdBottom) then EndPos := Width else EndPos := Height;
  if fScaleDir = rsdReverse then ThePos := EndPos - APos;
  Result := fOffset;
  if fUnits = ruPixel then Result := Trunc(Result) + Trunc(ThePos / Scale * 100); // zero-based counting of pixels
  if fUnits = ruInch  then Result := Result + ThePos / Scale * 100 / Screen.PixelsPerInch;
  if fUnits = ruCenti then Result := Result + ThePos / Scale * 100 / Screen.PixelsPerInch * 2.54;
  if fUnits = ruMilli then Result := Result + ThePos / Scale * 100 / Screen.PixelsPerInch * 25.4;
  if fUnits = ruMeter then Result := Result + ThePos / Scale * 100 / Screen.PixelsPerInch * 0.0254;
  if fUnits = ruMeter then Result := Result + ThePos / Scale * 100 / Screen.PixelsPerInch * 0.0000254;
end;

procedure TRsRuler.SetOffset(const Value: Double);
begin
  if Value <> fOffset then
  begin
    fOffset := Value;
    Invalidate;
  end;
end;

procedure TRsRuler.SetShowMinus(const Value: Boolean);
begin
  if Value <> fShowMinus then
  begin
    fShowMinus := Value;
    Invalidate;
  end;
end;

function TRsRuler.ConvertOffset(ToUnit: TRulerUnit): Double;
var
  DivFactor, MulFactor: Double;
begin
  DivFactor := 1; // std: ruMilli
  if (fUnits = ruCenti) then DivFactor := 0.1;
  if (fUnits = ruMeter) then DivFactor := 0.001;
  if (fUnits = ruKilo) then DivFactor := 0.000001;
  if (fUnits = ruInch) then DivFactor := 1 / 25.4;
  if (fUnits = ruPixel) then DivFactor := Screen.PixelsPerInch / 25.4;
  MulFactor := 1;
  if (ToUnit = ruCenti) then MulFactor := 0.1;
  if (ToUnit = ruMeter) then MulFactor := 0.001;
  if (ToUnit = ruKilo) then MulFactor := 0.000001;
  if (ToUnit = ruMilli) then MulFactor := 1;
  if (ToUnit = ruInch) then MulFactor := 1 / 25.4;
  if (ToUnit = ruPixel) then MulFactor := Screen.PixelsPerInch / 25.4;
  Result := fOffset / DivFactor * MulFactor;
end;

{ TRsRulerCorner }

constructor TRsRulerCorner.Create(AOwner: TComponent);
begin
  inherited;
  fPosition := cpLeftTop;
  fUStr := Centi;
  Width := 24;
  Height := 24;
  Hint := 'centimeter';
end;

procedure TRsRulerCorner.Paint;
var
  Wi, He, d: Integer;
  R: TRect;
begin
  inherited;
  R := ClientRect;
  SelectObject(Canvas.Handle, NormFont);
  with Canvas do
  begin
    if Not Flat then DrawEdge(Handle, R, EDGE_RAISED, BF_RECT);
    Brush.Color := fScaleColor;
    He := TextHeight('0') + 6;
    SetBKMode(Handle, TRANSPARENT);
    Canvas.Font.Color := Font.Color;
    Wi := TextWidth(fUStr);
    d := 2 - Integer(Flat);
    if fPosition = cpLeftTop then
    begin
      FillRect(Rect(Width - He, Height - He - 1, Width - d, Height - 8));
      FillRect(Rect(Width - He, Height - He, Width - 8, Height - d));
      TextOut(Width - He + 1 + (He - 2 - Wi) div 2, Height - He - 1, fUStr);
    end;
    if fPosition = cpRightTop then
    begin
      FillRect(Rect(d, Height - He - 1, He, Height - 8));
      FillRect(Rect(8, Height - He, He, Height - d));
      TextOut(2 + (He - Wi) div 2, Height - He, fUStr);
    end;
    if fPosition = cpLeftBottom then
    begin
      FillRect(Rect(Width - He, 8, Width - d, He + 1));
      FillRect(Rect(Width - He, d, Width - 8, He));
      TextOut(Width - He + 1 + (He - 2 - Wi) div 2, 8, fUStr);
    end;
    if fPosition = cpRightBottom then
    begin
      FillRect(Rect(d, 8, He, He + 1));
      FillRect(Rect(8, d, He, He));
      TextOut(2 + (He - Wi) div 2, 8, fUStr);
    end;
  end;
  //Canvas.Font.Height := OrgH;
  SetBKMode(Canvas.Handle, OPAQUE);
  SelectObject(Canvas.Handle, OldFont);
end;



procedure TRsRulerCorner.SetPosition(const Value: TCornerPos);
begin
  if Value <> fPosition then
  begin
    fPosition := Value;
    Invalidate;
  end;
end;

procedure TRsRulerCorner.SetUnit(const Value: TRulerUnit);
begin
  if Value <> fUnits then
  begin
    fUnits := Value;
    if fUnits = ruKilo then begin fUStr := Kilo; Hint := 'kilometer'; end;
    if fUnits = ruMeter then begin fUStr := Meter; Hint := 'meter'; end;
    if fUnits = ruCenti then begin fUStr := Centi; Hint := 'centimeter'; end;
    if fUnits = ruMilli then begin fUStr := Milli; Hint := 'millimeter'; end;
    if fUnits = ruInch then begin fUStr := Inch; Hint := 'inch'; end;
    if fUnits = ruPixel then begin fUStr := Pixel; Hint := 'pixel'; end;
    if fUnits = ruNone then begin fUStr := None; Hint := ''; end;
    Invalidate;
  end;
end;



end.