CustomRuler

Top  Previous  Next

{ Custom Ruler component: Can be used for image editing applications by setting

the RulerType property to rtGrafix or use for document editing applications by

setting to rtDocument. This creates a ruler, well almost like MS Word, with

similar functionality. Will snap to divisions on the Inches/Centimeters/Pica/Pixel

scale.

 

There is no warranty expressed or implied regarding this software.

Is given as is, as Freeware. You are free to use for any commercial or

non commercial purposes or to modify the source. However I would appreciate an

email informing me of how this is being used or what the modifications are like

just so i can pick a few tricks I might not know. Have fun.

 

sxb0@Lycos.com [Ess Ex Bee Zero At Lycos Dot Com]}

 

unit CustomRuler;

 

interface

 

uses

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

 

type

TDivType = (dvPixels,dvInches,dvCentimeters,dvPicas);

TRulerDir = (rdVertical, rdHorizontal);

TGraphicRuler = class(TCustomControl)

private

  FOnMouseDown: TMouseEvent;

  FOnMouseMove: TMouseMoveEvent;

  FOnMouseUp: TMouseEvent;

  FDir: TRulerDir;

  FRulerTop: Boolean;

  FBgColor: TColor;

  FFont: TFont;

  FmarkerColor: TColor;

  FFramed: Boolean;

  FClicked: Boolean;

  FDivType: TDivType;

  FChanged: Boolean;

  FChanging: Boolean;

  FScale: single;

  FScroll: Integer;

  FOnChanged: TNotifyEvent;

  FOnStop: TNotifyEvent;

  FOnBegin: TNotifyEvent;

  procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;

  procedure DrawRuler;

  function ZtoXY(A: Integer): Integer;

  procedure SetScale(Value: Single);

  procedure SetHScroll(Value: Integer);

protected

  procedure SetBgColor(Value: TColor);

  procedure SetDivType(Value: TDivType);

  procedure SetFontProp(Value: TFont);

  procedure SetMarkerColor(Value: TColor);

  function GetFontProp: TFont;

  procedure SetFramed(Value: Boolean);

  procedure SetRulerCenter(Value: Boolean);

  procedure SetRulerDir(Value: TRulerDir);

  procedure WMSize(var Message: TWMSize); message WM_SIZE;

  procedure Paint; override;

public

  procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

  procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

  procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

  constructor Create(AOwner: TComponent); override;

  destructor Destroy; override;

published

  property Align;

  property Visible;

  property Enabled;

  property Cursor;

  property DragMode;

  property DragCursor;

  property Font: TFont read GetFontProp write SetFontProp;

  property ParentShowHint;

  property ShowHint;

  property TabOrder;

  property Divisions: TDivType read FDivType write SetDivType default dvPixels;

  property BackColor: TColor read FBgColor write SetBgColor default clWhite;

  property RulerColor: TColor read FMarkerColor write SetMarkerColor default clBlack;

  property Framed: Boolean read FFramed write SetFramed;

  property MarkerOnTop: Boolean read FRulerTop write SetRulerCenter;

  property Direction: TRulerDir read FDir write SetRulerDir default rdHorizontal;

  property Scale: Single read FScale write SetScale;

  property OnClick;

  property OnDblClick;

  property OnEnter;

  property OnExit;

  property OnMouseDown : TMouseEvent read FOnMouseDown write FOnMouseDown;

  property OnMouseMove : TMouseMoveEvent read FOnMouseMove write FOnMouseMove;

  property OnMouseUp : TMouseEvent read FOnMouseUp write FOnMouseUp;

  property OnKeyDown;

  property OnKeyUp;

  property OnKeyPress;

  property OnDragOver;

  property OnDragDrop;

  property OnEndDrag;

  property OnStartDrag;

  property OnBeginChange: TNotifyEvent read FOnBegin write FOnBegin;

  property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;

  property OnStopChanged: TNotifyEvent read FOnStop write FOnStop;

  property Scroll: Integer read FScroll write SetHScroll;

end;

 

procedure Register;

 

implementation

 

procedure Register;

begin

RegisterComponents('AL', [TGraphicRuler]);

end;

 

procedure TGraphicRuler.Paint;

begin

with Canvas do

begin

  Brush.Color := FBgColor;

  Brush.Style := bsSolid;

  FillRect(Rect(0,0,Width,Height));

  Pen.Color := FMarkerColor;

  Pen.Width := 1;

end;

DrawRuler;

end;

 

function Fmod(const X, Y: Single): Single;

begin

Result := X - System.Int(X / Y) * Y;

end;

 

function TGraphicRuler.ZtoXY(a: integer): integer;

var zx: single;

begin

zx := FScale * 100;

//if FScale > 1 then

Result := (a * round(zx)) div 100

//else Result := ((a * round(zx)) div 100) shl 1;

end;

 

procedure TGraphicRuler.DrawRuler;

var I,T1,T2,T3,T4,L,H,H2,W,Th,Tw,X: Integer;

  S: string;

  R: TRect;

 

  procedure DwText(Left,Top: Integer; St: string);

  var LogRec : TLogFont;

  OldFont, NewFont : HFont;

  begin

    GetObject(canvas.Font.Handle, SizeOf(LogRec), @LogRec);

    LogRec.lfEscapement := 90 * 10;

    Logrec.lfOutPrecision := OUT_TT_ONLY_PRECIS;

    NewFont := CreateFontIndirect(LogRec);

    OldFont := SelectObject( Canvas.Handle, NewFont);

    Tw := Canvas.TextWidth(St) shr 1;

    Th := Canvas.TextHeight(St) shr 1;

    //canvas.Brush.Style := bsClear;

    if Top > 0 then

    //canvas.TextOut(Left,Top+ Tw, St);

    TextOut(Canvas.Handle,Left,(Top+Tw)-FScroll,PChar(St),StrLen(PChar(St)));

    NewFont := SelectObject(Canvas.Handle, OldFont);

    DeleteObject(NewFont);

  end;

begin

T1 := 0; T2 := 10; T3 := 12; T4 := 14;

L := 0;

if FDir = rdHorizontal then

begin

  X := 0; H := Height -1; W := (Width -1)+FScroll; H2 := H shr 1;

end else

begin

  X := 0; H := Width -1; W := (Height -1)+FScroll; H2 := H shr 1;

end;

if FScale = 0.5 then W := W shl 1

else if FScale = 0.25 then W := W * 4

else W := Round(W / FScale);

 

case FDivType of

  dvPixels :

  begin

    Canvas.Pen.Color := FMarkerColor;

    for I := X to W do

    begin

      if (I mod 10 = 0) then

      begin

        if FDir = rdHorizontal then

        begin

          MoveToEx(Canvas.Handle,Ztoxy(I+L-FScroll),T3,nil);

          LineTo(Canvas.Handle,Ztoxy(I+L-FScroll), H);

        end else

        begin

          MoveToEx(Canvas.Handle,T3, Ztoxy(I+L-FScroll),nil);

          LineTo(Canvas.Handle,H, Ztoxy(I+L-FScroll));

        end;

      end;

 

      if FScale > 0.5 then

      begin

        if (I mod 5 = 0) then

        begin

          if FDir = rdHorizontal then

          begin

            MoveToEx(Canvas.Handle,Ztoxy(I+L-FScroll),T4,nil);

            LineTo(Canvas.Handle,Ztoxy(I+L-FScroll),H);

          end else

          begin

            MoveToEx(Canvas.Handle,T4, Ztoxy(I+L-FScroll),nil);

            LineTo(Canvas.Handle,H, Ztoxy(I+L-FScroll));

          end;

        end;

      end;

 

      if FScale > 0.5 then

      begin

        if I mod 50 = 0 then

        begin

          Canvas.Pen.Color := FFont.Color;

          S := IntToStr(I);

          if FDir = rdHorizontal then

          begin

            Tw := Canvas.TextWidth(S) shr 1;

            Th := Canvas.TextHeight(S) shr 1;

            if ZToXY(I+L) > 0 then

            //TextOut(ZToXY(I+L)- Tw,0,S);

            TextOut(Canvas.Handle,(ZtoXY(i+l)-Tw)-FScroll,0,PChar(s),StrLen(PChar(s)));

            Canvas.Pen.Color := FMarkerColor;

            MoveToEx(Canvas.Handle,Ztoxy(I+L-FScroll), T2,nil);

            LineTo(Canvas.Handle,Ztoxy(I+L-FScroll), H);

            Canvas.Pen.Color := FMarkerColor;

          end else

          begin      //rdVertical

            DwText(0,ZtoXY(I+L), S);

            Canvas.Pen.Color := FMarkerColor;

            MoveToEx(Canvas.Handle,T2, Ztoxy(I+L-FScroll),nil);

            LineTo(Canvas.Handle,H, Ztoxy(I+L-FScroll));

            Canvas.Pen.Color := FMarkerColor;

          end;

        end;  //i mod 50 = 0

      end else

      begin

        if I mod 100 = 0 then

        begin

          Canvas.Pen.Color := FFont.Color;

          S := IntToStr(I);

          if FDir = rdHorizontal then

          begin

            Tw := Canvas.TextWidth(S) shr 1;

            Th := Canvas.TextHeight(S) shr 1;

            if ZToXY(I+L) > 0 then

            //TextOut(ZToXY(I+L)- Tw,0,S);

            TextOut(Canvas.Handle,(ztoxy(i+l)-tw)-FScroll,0,PChar(s),StrLen(PChar(s)));

            Canvas.Pen.Color := FMarkerColor;

            MoveToEx(Canvas.Handle,Ztoxy(I+L-FScroll), T2,nil);

            LineTo(Canvas.Handle,Ztoxy(I+L-FScroll), H);

            Canvas.Pen.Color := FMarkerColor;

          end else

          begin      //rdVertical

            DwText(0,ZtoXY(I+L), S);

            Canvas.Pen.Color := FMarkerColor;

            MoveToEx(Canvas.Handle,T2, Ztoxy(I+L-FScroll),nil);

            LineTo(Canvas.Handle,H, Ztoxy(I+L-FScroll));

            Canvas.Pen.Color := FMarkerColor;

          end;

        end;

      end; // fscale < 0.5

    end;

  end;

  dvInches :

  begin

    Canvas.Pen.Color := FMarkerColor;

    for I := X to W do

    begin

      if I mod 72 = 0 then

      begin

        Canvas.Pen.Color := FFont.Color;

        S := IntToStr((I) div 72);

        if FDir = rdHorizontal then

        begin

          Tw := Canvas.TextWidth(S) shr 1;

          Th := Canvas.TextHeight(S) shr 1;

          if ZtoXY(I+L) > 0 then

          //TextOut(ZtoXY(I+L)- Tw,T1,S);

          TExtOut(Canvas.Handle,ztoxy(i+l)-Tw,T1,PChar(S),StrLen(PChar(S)));

          Canvas.Brush.Style := bsSolid;

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll), T2,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll), H);

        end else //rdVert

        begin

          if ZtoXY(I+L) > 0 then

          DwText(T1,ZtoXY(I+L),S);

          Canvas.Brush.Style := bsSolid;

          MoveToEx(Canvas.Handle,T2, ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H, ZtoXY(I+L));

        end;

        Canvas.Pen.Color := FMarkerColor;

      end;

 

      if (I mod 36 = 0) then

      begin

        if FDir = rdHorizontal then

        begin

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T3,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

        end else

        begin

          MoveToEx(Canvas.Handle,T3,ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H,ZtoXY(I+L));

        end;

      end;

      if I mod 9 = 0 then

      begin

        if FDir = rdHorizontal then

        begin

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T4,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

        end else

        begin

          MoveToEx(Canvas.Handle,T4,ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H,ZtoXY(I+L));

        end;

      end;

    end;

  end;

  dvPicas :

  begin

    Canvas.Pen.Color := FMarkerColor;

    for I := X to W do

    begin

      if FScale > 0.5 then

      begin

        if I mod 12 = 0 then

        begin

          if FDir = rdHorizontal then

          begin

            MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll), T2,nil);

            LineTo(Canvas.Handle,ZtoXY(I+L+FScroll), H);

          end else

          begin

            MoveToEx(Canvas.Handle,T2, ZtoXY(I+L),nil);

            LineTo(Canvas.Handle,H, ZtoXY(I+L));

          end;

        end;

      end else

      begin

        if I mod 24 = 0 then

        begin

          if FDir = rdHorizontal then

          begin

            MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll), T2,nil);

            LineTo(Canvas.Handle,ZtoXY(I+L+FScroll), H);

          end else

          begin

            MoveToEx(Canvas.Handle,T2, ZtoXY(I+L),nil);

            LineTo(Canvas.Handle,H, ZtoXY(I+L));

          end;

        end;

      end;

      Canvas.Pen.Color := FFont.Color;

      S := IntToStr((I) div 12);

      if FScale > 0.5 then

      begin

        if FDir = rdHorizontal then

        begin

          Tw := Canvas.TextWidth(S) shr 1;

          Th := Canvas.TextHeight(S) shr 1;

          if I mod 24 = 0 then TextOut(Canvas.Handle,ztoxy(i+l)-tw,T1,PChar(s),StrLen(PChar(s)))  //TextOut(ZtoXY(I+L)- Tw,T1,S)

        end else

        begin

          if I mod 24 = 0 then DwText(T1,ZtoXY(I+L),S)  //TextOut((I+L)- Tw,T1,S)

        end;

        //----------SUB DIVISION

        if I mod 6 = 0 then

        begin

          if FDir = rdHorizontal then

          begin

            MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T3,nil);

            LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

          end else

          begin

            MoveToEx(Canvas.Handle,T3, ZtoXY(I+L),nil);

            LineTo(Canvas.Handle,H, ZtoXY(I+L));

          end;

        end;

      end else

      begin

        if FDir = rdHorizontal then

        begin

          Tw := Canvas.TextWidth(S) shr 1;

          Th := Canvas.TextHeight(S) shr 1;

          if I mod 48 = 0 then TextOut(Canvas.Handle,ztoxy(i+l)-tw,t1,PChar(s),StrLen(PChar(s)))  //TextOut(ZtoXY(I+L)- Tw,T1,S)

        end else

        begin

          if I mod 48 = 0 then DwText(T1,ZtoXY(I+L),S)  //TextOut((I+L)- Tw,T1,S)

        end;

      end;

      Canvas.Pen.Color := FMarkerColor;

    end;

  end;

 

  dvCentimeters :

  begin

    Canvas.Pen.Color := FMarkerColor;

    for I := X to W do

    begin

      if I mod 14 = 0 then

      begin

        if FDir = rdHorizontal then

        begin

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T3,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

        end else

        begin

          MoveToEx(Canvas.Handle,T3, ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H, ZtoXY(I+L));

        end;

      end;

      if I mod 7 = 0 then

      begin

        if FDir = rdHorizontal then

        begin

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T4,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

        end else

        begin

          MoveToEx(Canvas.Handle,T4, ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H, ZtoXY(I+L));

        end;

      end;

      if I mod 28 = 0 then

      begin

        Canvas.Pen.Color := FFont.Color;

        Canvas.Brush.Style := bsSolid;

        S := IntToStr((I) div 28);

        if FDir = rdHorizontal then

        begin

          Tw := Canvas.TextWidth(S) shr 1;

          Th := Canvas.TextHeight(S) shr 1;

          if (ZtoXY(I+L)) > 0 then

          //TextOut((ZtoXY(I+L)) - Tw,T1,S);

          TextOut(Canvas.Handle,ZtoXY(I+L)-Tw,T1,PChar(S),StrLen(PChar(S)));

          Canvas.Pen.Color := FMarkerColor;

          MoveToEx(Canvas.Handle,ZtoXY(I+L+FScroll),T2,nil);

          LineTo(Canvas.Handle,ZtoXY(I+L+FScroll),H);

        end else

        begin

          if (ZtoXY(I+L)) > 0 then

          DwText(T1,(ZtoXY(I+L)),S);

          Canvas.Pen.Color := FMarkerColor;

          MoveToEx(Canvas.Handle,T2, ZtoXY(I+L),nil);

          LineTo(Canvas.Handle,H, ZtoXY(I+L));

        end;

        Canvas.Pen.Color := FMarkerColor;

      end;

    end;

  end;

end; //case

R := ClientRect;

DrawEdge(Canvas.Handle,R,BDR_RAISEDOUTER,BF_RECT);

end;

 

 

 

procedure TGraphicRuler.WMEraseBkgnd(var Message: TWmEraseBkgnd);

begin

Message.Result := 1;

end;

 

procedure TGraphicRuler.WMSize(var Message: TWMSize);

begin

//

end;

 

 

 

constructor TGraphicRuler.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

ControlStyle := ControlStyle + [csOpaque,csFramed];

FScroll := 0;

FDivType := dvPixels;

FDir := RDHorizontal;

Width := 100;

Height := 26;

Canvas.Font.Name := 'MS Serif';

Canvas.Font.Size := 7;

FScale := 1;

FBgColor := clWhite;

FMarkerColor := clBlack;

FFont := Canvas.Font;

FRulerTop := True;

FFramed := True;

FClicked := False;

FChanged := False;

FChanging := False;

end;

 

destructor TGraphicRuler.Destroy;

begin

inherited;

end;

 

procedure TGraphicRuler.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

if (Button = mbLeft) then

begin

  if Assigned(FOnMouseDown) then FOnMouseDown(Self,Button,Shift,X,Y);

  if Assigned(FOnBegin) then FOnBegin(Self);

  if not FChanged then FChanged := True;

  //Paint;

end;

end;

 

procedure TGraphicRuler.MouseMove(Shift: TShiftState; X, Y: Integer);

begin

if (ssLeft in Shift) then

begin

  FChanging := True;

  if Assigned(FOnChanged) then FOnChanged(Self);

  if Assigned(FOnMouseMove) then FOnMouseMove(Self,Shift,X,Y);

  //Paint;

end;

end;

 

 

procedure TGraphicRuler.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

FChanging := False;

if FChanged then FChanged := False;

//Paint;

if Assigned(FOnStop) then FOnStop(Self);

if Assigned(FOnMouseUp) then FOnMouseUp(Self,Button,Shift,X,Y);

end;

 

procedure TGraphicRuler.SetDivType(Value: TDivType);

begin

if (Value <> FDivType) then

begin

  FDivType := Value;

  FChanged := True;

  Paint;

end;

end;

 

procedure TGraphicRuler.SetFontProp(Value: TFont);

begin

if (Value <> FFont) then

begin

  FFOnt := Value;

  Canvas.Font := Value;

  FChanged := True;

  Paint;

end;

end;

 

function TGraphicRuler.GetFontProp: TFont;

begin

Result := Canvas.Font;

end;

 

 

procedure TGraphicRuler.SetBgColor(Value: TColor);

begin

if (Value <> FBgColor) then

begin

  FBgColor := Value;

  FChanged := True;

  Paint;

end;

end;

 

procedure TGraphicRuler.SetMarkerColor(Value: TColor);

begin

if (Value <> FMarkerColor) then

begin

  FMarkerColor := Value;

  FChanged := True;

  Paint;

end;

end;

 

 

procedure TGraphicRuler.SetFramed(Value: Boolean);

begin

if (Value <> FFramed) then

begin

  FFramed := Value;

  if FFramed then ControlStyle := ControlStyle + [csFramed]

  else ControlStyle := ControlStyle - [csFramed];

  FChanged := True;

  Paint;

end;

end;

 

procedure TGraphicRuler.SetRulerCenter(Value: Boolean);

begin

if (Value <> FRulerTop) then

begin

  FRulerTop := Value;

  FChanged := True;

  Paint;

end;

end;

 

procedure TGraphicRuler.SetRulerDir(Value: TRulerDir);

begin

if (Value <> FDir) then

begin

  FDir := Value;

  FChanged := True;

  Paint;

end;

end;  

 

procedure TGraphicRuler.SetScale(Value: Single);

begin

if (Value <> FScale) then

begin

  FScale := Value;

  Paint;

  FChanged := True;

end;

end;  

 

procedure TGraphicRuler.SetHScroll(Value: Integer);

begin

if FScroll <> Value then

begin

  FScroll := Value;

  Invalidate;

end;

end;

 

end.