mmscale.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMScale;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Messages,
    Classes,
    SysUtils,
    Controls,
    ExtCtrls,
    Graphics,
    MMObj,
    MMUtils;

type
    TMMScaleStyle   = (stColor,stLowered,stRaised);
    TMMScaleOrigin  = (soInner,soOuter);

const
    defScaleVisible = True;
    defScaleColor   = clBlack;
    defScaleStyle   = stColor;
    defTickCount    = 11;
    defEnlargeEvery = 5;
    defScaleSize    = 7;
    defScaleOrigin  = soInner;
    defScaleConnect = False;

type
    EMMScaleError   = class(Exception);

    {-- TMMCustomScale ----------------------------------------------------}
    TMMCustomScale  = class(TPersistent)
    private
        FVisible        : Boolean;
        FStartAngle     : Integer;
        FEndAngle       : Integer;
        FColor          : TColor;
        FColor2         : TColor;
        FColor3         : TColor;
        FPoint1         : Integer;
        FPoint2         : Integer;
        FCanvas         : TCanvas;
        FStyle          : TMMScaleStyle;
        FTickCount      : Integer;
        FEnlargeEvery   : Integer;
        FSize           : Integer;
        FOrigin         : TMMScaleOrigin;
        FConnect        : Boolean;
        FOnChange       : TNotifyEvent;

        procedure   SetVisible(Value : Boolean);
        procedure   SetColor(Value : TColor);
        procedure   SetStyle(Value : TMMScaleStyle);
        procedure   SetTickCount(Value : Integer);
        procedure   SetEnlargeEvery(Value : Integer);
        procedure   SetSize(Value : Integer);
        procedure   SetOrigin(Value : TMMScaleOrigin);
        procedure   SetConnect(Value : Boolean);
        function    GetScaleHeight : Integer;
    protected
        procedure   Changed; virtual;
        procedure   DoChange; dynamic;
        procedure   ScaleLine(X1, Y1, X2, Y2: Integer; Color: TColor);
        procedure   ScaleArc(X1,Y1,X2,Y2,StAngle,EnAngle: Integer; Radius: Float);
        procedure   NeedCanvas;
    public
        constructor Create;
        procedure   Assign(Source : TPersistent); override;

        procedure   DrawRect(Canvas : TCanvas; R : TRect; TopLeft : Boolean);
        procedure   DrawElliptic(Canvas : TCanvas; R : TRect);

        property    StartAngle  : Integer read FStartAngle write FStartAngle;
        property    EndAngle    : Integer read FEndAngle write FEndAngle;
        property    Canvas      : TCanvas read FCanvas write FCanvas;
        property    Color2      : TColor read FColor2 write FColor2;
        property    Color3      : TColor read FColor3 write FColor3;
        property    Point1      : Integer read FPoint1 write FPoint1;
        property    Point2      : Integer read FPoint2 write FPoint2;

        property    ScaleHeight : Integer read GetScaleHeight;

        property    OnChange    : TNotifyEvent read FOnChange write FOnChange;
    protected
        property Visible: Boolean read FVisible write SetVisible;
        property Color: TColor read FColor write SetColor;
        property Style: TMMScaleStyle read FStyle write SetStyle;
        property TickCount: Integer read FTickCount write SetTickCount;
        property EnlargeEvery: Integer read FEnlargeEvery write SetEnlargeEvery;
        property Size: Integer read FSize write SetSize;
        property Origin: TMMScaleOrigin read FOrigin write SetOrigin;
        property Connect: Boolean read FConnect write SetConnect;
    end;

    {-- TMMScale --------------------------------------------------------}
    TMMScale    = class(TMMCustomScale)
    published
        property Visible;
        property Color;
        property Style;
        property TickCount;
        property EnlargeEvery;
        property Size;
        property Origin;
        property Connect;
    end;

implementation

{== TMMCustomScale =======================================================}
constructor TMMCustomScale.Create;
begin
    inherited Create;

    FVisible      := defScaleVisible;
    FColor        := defScaleColor;
    FColor2       := defScaleColor;
    FColor3       := defScaleColor;
    FStyle        := defScaleStyle;
    FTickCount    := defTickCount;
    FEnlargeEvery := defEnlargeEvery;
    FSize         := defScaleSize;
    FOrigin       := defScaleOrigin;
    FConnect      := defScaleConnect;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure   TMMCustomScale.SetVisible(Value: Boolean);
begin
   if FVisible <> Value then
   begin
      FVisible := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetColor(Value: TColor);
begin
   if FColor <> Value then
   begin
      FColor    := Value;
      FColor2   := Value;
      FColor3   := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetStyle(Value: TMMScaleStyle);
begin
   if FStyle <> Value then
   begin
      FStyle := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetTickCount(Value: Integer);
begin
   Value := MinMax(Value, 2, MaxInt);
   if FTickCount <> Value then
   begin
      FTickCount := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetEnlargeEvery(Value: Integer);
begin
   Value := MinMax(Value, 1, MaxInt);
   if FEnlargeEvery <> Value then
   begin
      FEnlargeEvery := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetSize(Value: Integer);
begin
   Value := MinMax(Value, 1, MaxInt);
   if FSize <> Value then
   begin
      FSize := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetOrigin(Value: TMMScaleOrigin);
begin
   if FOrigin <> Value then
   begin
      FOrigin := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.SetConnect(Value: Boolean);
begin
   if FConnect <> Value then
   begin
      FConnect := Value;
      Changed;
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
function TMMCustomScale.GetScaleHeight: Integer;
begin
   Result := FSize;
   if FConnect then
   begin
      Inc(Result);
      if Style <> stColor then Inc(Result);
   end;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.Changed;
begin
   DoChange;
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.DoChange;
begin
   if Assigned(FOnChange) then FOnChange(Self);
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.Assign(Source: TPersistent);
var
    S: TMMScale;
begin
   if Source is TMMScale then
   begin
      S             := (Source as TMMScale);
      FVisible      := S.FVisible;
      FColor        := S.FColor;
      FStyle        := S.FStyle;
      FTickCount    := S.FTickCount;
      FEnlargeEvery := S.FEnlargeEvery;
      FSize         := S.FSize;
      FOrigin       := S.FOrigin;
      FConnect      := S.FConnect;
      Changed;
    end
    else inherited Assign(Source);
end;

{-------------------------------------------------------------------------}
function RRound(Base, V: Float): LongInt;
begin
   if V >= Base then
      Result := Trunc(V)
   else
      Result := Round(V);
end;

{-------------------------------------------------------------------------}
procedure CalcPoint(OrigX, OrigY, A, R: Float; var X, Y: Integer);
var
   Ang: Float;
begin
   Ang := A / 180 * Pi;
   X   := RRound(OrigX,OrigX + R*Cos(Ang));
   Y   := RRound(OrigY,OrigY - R*Sin(Ang));
end;

{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.DrawRect(Canvas: TCanvas; R: TRect; TopLeft: Boolean);
var
   W, H        : Integer;
   Inner       : Boolean;
   Offs, Len   : Float;
   Horz        : Boolean;
   Sz          : Integer;
   i           : Integer;
   Left        : Integer;
   Top         : Integer;
   Right       : Integer;
   Bottom      : Integer;
   MultiColor  : Boolean;
   Len1, Len2  : Float;
   C           : TColor;
   TickSize    : Float;

   function Patch: Integer;
   begin
      if Connect and (Style <> stColor) then
         Result := 1
      else
         Result := 0;
   end;

   procedure HorzLine(X1, Y1, X2: Integer);
   begin
      if MultiColor then
      begin