prscale.pas

是 delphi6的函数库

unit PRScale;


interface

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

const
  Centi: String = 'cm';
  Milli: String = 'mm';
  Inch: String = 'in';
  None: String = '';

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

  TPRScale = class(TGraphicControl)
  private
    fDirection: TRulerDir;   //方向
    fUnits: TRulerUnit;      //单位
    fScale: Integer;         //比例
    fScaleFactor: Double;    //比例因数
    fAdvance: Double;        //前进
    fFlat: Boolean;
    fHairLine: Boolean;
    fHairLinePos: Integer;
    fHairLineStyle: THairLineStyle;
    procedure SetDirection(const Value: TRulerDir);
    procedure SetScale(const Value: Integer);
    procedure SetUnit(const Value: TRulerUnit);
    procedure SetFlat(const Value: Boolean);
    procedure SetHairLine(const Value: Boolean);
    procedure SetHairLinePos(const Value: Integer);
    procedure SetHairLineStyle(const Value: THairLineStyle);
  protected
    LeftSideLF, RightSideLF, NormLF: TLogFont;
    NormFont, LeftSideFont, RightSideFont: HFont;
    FirstTime: Boolean;
    procedure DrawHairLine;
    procedure CalcAdvance;
    procedure PaintScaleTics;
    procedure PaintScaleLabels;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Direction: TRulerDir read fDirection write SetDirection;
    property Units: TRulerUnit read fUnits write SetUnit;
    property Scale: Integer read fScale write SetScale;
    property Flat: Boolean read fFlat write SetFlat;
    property HairLine: Boolean read fHairLine write SetHairLine;
    property HairLinePos: Integer read fHairLinePos write SetHairLinePos;
    property HairLineStyle: THairLineStyle read fHairLineStyle write SetHairLineStyle;
    property Height;
    property Width;
    property Visible;
    property Hint;
    property ShowHint;
    property Tag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
    property OnResize;
  end;

  TPRScaleCorner = class(TGraphicControl)
  private
    fPosition: TCornerPos;
    fFlat: Boolean;
    fUnits: TRulerUnit;
    procedure SetPosition(const Value: TCornerPos);
    procedure SetFlat(const Value: Boolean);
    procedure SetUnits(const Value: TRulerUnit);
  protected
    fUStr: String;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property Position: TCornerPos read fPosition write SetPosition;
    property Flat: Boolean read fFlat write SetFlat;
    property Units: TRulerUnit read fUnits write SetUnits;
    property Height;
    property Width;
    property Visible;
    property Hint;
    property ShowHint;
    property Tag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
    property OnResize;
  end;
procedure Register;
implementation
{$R *.RES}
procedure Register;
begin
  RegisterComponents('YS', [TPRScale]);
end;
{ TPRScale }
constructor TPRScale.Create(AOwner: TComponent);
begin
  inherited;
  fDirection := rdTop;
  fUnits := ruCenti;
  fScale := 100;
  Color := clBtnFace;
  Height := 24;
  Width := 200;
  fScaleFactor := 1;
  fAdvance := 1;
  with LeftSideLF do
  begin
    FillChar(LeftSideLF, SizeOf(LeftSideLF), 0);
    lfHeight := 11;//8;//11;
    lfEscapement := 900;
    lfOrientation := 900;
    StrPCopy(lfFaceName, 'Tahoma');
    //StrPCopy(lfFaceName, 'MS Sans Serif');
  end;
  with RightSideLF do
  begin
    FillChar(RightSideLF, SizeOf(RightSideLF), 0);
    lfHeight := 11;//8;//11;
    lfEscapement := 2700;
    lfOrientation := 2700;
    StrPCopy(lfFaceName, 'Tahoma');
    //StrPCopy(lfFaceName, 'MS Sans Serif');
  end;
  with NormLF do
  begin
    FillChar(NormLF, SizeOf(NormLF), 0);
    lfHeight := 11;//8;//11;
    StrPCopy(lfFaceName, 'Tahoma');
    //StrPCopy(lfFaceName, 'MS Sans Serif');
  end;
  FirstTime := True;
  fFlat := False;
  fHairLinePos := -1;
  fHairLine := False;
  fHairLineStyle := hlsLine;
end;

destructor TPRScale.Destroy;
begin
  DeleteObject(NormFont);
  DeleteObject(LeftSideFont);
  DeleteObject(RightSideFont);
  inherited;
end;

procedure TPRScale.CalcAdvance;
begin
  fAdvance := Screen.PixelsPerInch / 10 * Scale / 100;
  if fUnits <> ruInch then fAdvance := fAdvance / 2.54;
  case Scale 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..99: fScaleFactor := 1;
    100..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 TPRScale.PaintScaleTics;
var
  Pos: Double;
  N, Last, LongTick: Integer;
begin
  if (fDirection = rdTop) or (fDirection = rdBottom) then Last := Width else Last := Height;
  Pos := 0;
  N := 0;
  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(Trunc(Pos), Height - 1);
        LineTo(Trunc(Pos), Height - LongTick);
      end;
      if fDirection = rdBottom then
      begin
        MoveTo(Trunc(Pos), 1);
        LineTo(Trunc(Pos), LongTick);
      end;
    end else
    begin
      if fDirection = rdLeft then
      begin
        MoveTo(Width - 1, Trunc(Pos));
        LineTo(Width - LongTick, Trunc(Pos));
      end;
      if fDirection = rdRight then
      begin
        MoveTo(1, Trunc(Pos));
        LineTo(LongTick, Trunc(Pos));
      end;
    end;
    Inc(N);
    Pos := Pos + 2 * fAdvance; // always advance two units to next ticmark
  end;
end;

procedure TPRScale.PaintScaleLabels;
var
  Pos, Number: Double;
  N, Last, Wi, He: Integer;
  S: String;
begin
  if (fDirection = rdTop) or (fDirection = rdBottom) then Last := Width else Last := Height;
  Pos := 0;
  N := 0;
  while Pos < Last do with Canvas do
  begin
    Pen.Color := clBlack;
    Number := fScaleFactor * N / 10;
    if Units = ruMilli then Number := 10 * Number;
    S := FloatToStr(Number);
    Wi := TextWidth(S);
    He := TextHeight(S);
    if (fDirection = rdTop) or (fDirection = rdBottom) then
    begin
      MoveTo(Trunc(Pos), 1);  // only Pos is important
      if fDirection = rdTop then
      begin
        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
          MoveTo(Trunc(Pos), Height - 12);
          LineTo(Trunc(Pos), Height - 16);
        end;
      end;
      if fDirection = rdBottom then
      begin
        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
          MoveTo(Trunc(Pos), 12);
          LineTo(Trunc(Pos), 16);
        end;
      end;
    end else
    begin
      MoveTo(1, Trunc(Pos));
      if fDirection = rdLeft then
      begin
        if (N > 0) and (N mod 10 = 0) then TextOut(Width - He - 8, PenPos.Y + Wi div 2, S)
        else if (N > 0) and (N mod 5 = 0) then
        begin
          MoveTo(Width - 12, Trunc(Pos));
          LineTo(Width - 16, Trunc(Pos));
        end;
      end;
      if fDirection = rdRight then
      begin
        if (N > 0) and (N mod 10 = 0) then TextOut(He + 8, PenPos.Y - Wi div 2, S)    // 8
        else if (N > 0) and (N mod 5 = 0) then
        begin
          MoveTo(12, Trunc(Pos));
          LineTo(16, Trunc(Pos));
        end;
      end;
    end;
    Inc(N);
    Pos := Pos + fAdvance;
  end;
end;

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

procedure TPRScale.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;      //syy 2004-1-18
     // Height := Dim.X;
    end;
    fDirection := Value;
    Invalidate;
  end;
end;

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

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

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

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

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

procedure TPRScale.DrawHairLine; //画细线
var
  He: Integer;
begin
  if fHairLine then if fHairLinePos <> -1 then with Canvas do
  begin
    Pen.Mode := pmNotXOr;
    Pen.Color := clBlue;
    He := TextHeight('0') + 10;//6;
    if fDirection = rdTop then
    begin
      if fHairLineStyle = hlsLine then
      begin
        MoveTo(fHairLinePos, Height - He);
        LineTo(fHairLinePos, Height - 8);
      end else InvertRect(Canvas.Handle, Rect(2, Height - He, fHairLinePos, Height - 8));
    end;
    if fDirection = rdBottom then
    begin
      if fHairLineStyle = hlsLine then
      begin
        MoveTo(fHairLinePos, 8);
        LineTo(fHairLinePos, He);
      end else InvertRect(Canvas.Handle, Rect(2, 8, fHairLinePos, He));
    end;
    if fDirection = rdLeft then
    begin
      if fHairLineStyle = hlsLine then
      begin
        MoveTo(Width - He, fHairLinePos);
        LineTo(Width - 8, fHairLinePos);
      end else InvertRect(Canvas.Handle, Rect(Width - He, 2, Width - 8, fHairLinePos));
    end;
    if fDirection = rdRight then
    begin
      if fHairLineStyle = hlsLine then
      begin
        MoveTo(8, fHairLinePos);
        LineTo(He, fHairLinePos);
      end else InvertRect(Canvas.Handle, Rect(8, 2, He, fHairLinePos));
    end;
     Pen.Color := clBlack;
  end;
end;



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

{ TPRScaleCorner }

constructor TPRScaleCorner.Create(AOwner: TComponent);
begin
  inherited;
  fPosition := cpLeftTop;
  fFlat := False;
  fUnits := ruCenti;
  fUStr := Centi;
  Width := 24;
  Height := 24;
  Hint := 'centimeter';
end;

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

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

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

procedure TPRScaleCorner.SetUnits(const Value: TRulerUnit);
begin
  if Value <> fUnits then
  begin
    fUnits := Value;
    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 = ruNone then begin fUStr := None; Hint := ''; end;
    Invalidate;
  end;
end;

end.