Delphi控件源码

开发平台：
Delphi

Mmscale.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  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
         ScaleLine(X1,Y1,Trunc(X1+Len1+TickSize),Y1,Color);
         ScaleLine(Trunc(X1+Len1+TickSize),Y1,Trunc(X1+Len2+TickSize),Y1,Color2);
         ScaleLine(Trunc(X1+Len2+TickSize),Y1,X2,Y1,Color3);
      end
      else
        ScaleLine(X1,Y1,X2,Y1,Color);
   end;
   procedure VertLine(X1, Y1, Y2: Integer);
   begin
    if MultiColor then
    begin
       ScaleLine(X1,Y1,X1,Trunc(Y1+Len1+TickSize),Color);
       ScaleLine(X1,Trunc(Y1+Len1+TickSize),X1,Trunc(Y1+Len2+TickSize),Color2);
       ScaleLine(X1,Trunc(Y1+Len2+TickSize),X1,Y2,Color3);
    end
    else
       ScaleLine(X1,Y1,X1,Y2,Color);
   end;
begin
   MultiColor := ((Color2 <> Color) or (Color3 <> Color)) and
                 (Point1 >= 0) and (Point2 >= Point1) and
                 (Point1 <= TickCount) and (Point2 <= TickCount) and
                 (Style = stColor);
   W    := R.Right - R.Left;
   H    := R.Bottom - R.Top;
   Horz := W > H;
   if Horz then
      Len := W
   else
      Len := H;
   if MultiColor then
   begin
      Len1    := Point1/TickCount*Len;
      Len2    := Point2/TickCount*Len;
      TickSize:= 1/TickCount*Len;
   end;
   Inner := Origin = soInner;
   if not TopLeft then
      Inner := not Inner;
   if Connect then
      if Horz then
         if Inner then
            HorzLine(R.Left, R.Bottom-Patch, R.Right + 1)
         else
            HorzLine(R.Left, R.Top-1, R.Right + 1)
      else
         if Inner then
            VertLine(R.Right-1-Patch, R.Top+1, R.Bottom + 1)
         else
            VertLine(R.Left, R.Top+1, R.Bottom + 1);
   for i := 0 to TickCount-1 do
   begin
      Offs := i * (Len/(TickCount-1));
      if Horz then
      begin
         if (i mod EnlargeEvery) = 0 then
             Sz := FSize
         else
             Sz := FSize div 2;
         Left    := Trunc(R.Left + Offs);
         Right   := Left;
         if Inner then
         begin
            Top     := R.Bottom - Sz;
            Bottom  := R.Bottom;
         end
         else
         begin
            Top     := R.Top;
            Bottom  := R.Top + Sz;
         end
      end
      else
      begin
         if (i mod EnlargeEvery) = 0 then
             Sz := FSize
         else
             Sz := FSize div 2;
         Top     := Round(R.Top + Offs);
         Bottom  := Top;
         if Inner then
         begin
            Left    := R.Right - Sz - Patch;
            Right   := R.Right - Patch;
         end
         else
         begin
            Left    := R.Left + Patch;
            Right   := R.Left + Sz + Patch;
         end;
      end;
      if MultiColor then
        if Offs > Len1 then
            if Offs > Len2 then
                C := Color3
            else
                C := Color2
        else
            C := Color
      else
        C := Color;
      ScaleLine(Left, Top, Right, Bottom,C);
   end;
end;
{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.DrawElliptic(Canvas: TCanvas; R: TRect);
var
   OrigX, OrigY: Float;
   TickAngle   : Float;
   dAngle      : Integer;
   Angle       : Float;
   i           : Integer;
   Radius      : Float;
   RW, RH      : Float;
   ConnRad     : Float;
   ConnRect    : TRect;
   Temp        : Integer;
   procedure DrawAngledLine(Angle: Float; R1, R2: Float);
   var
      X1, Y1: Integer;
      X2, Y2: Integer;
   begin
      CalcPoint(OrigX,OrigY,Angle,R1,X1,Y1);
      CalcPoint(OrigX,OrigY,Angle,R2,X2,Y2);
      ScaleLine(X1, Y1, X2, Y2,Color);
   end;
begin
   RW := (R.Right - R.Left) / 2;
   RH := (R.Bottom - R.Top) / 2;
   OrigX := R.Left + RW;
   OrigY := R.Top + RH;
   if RW < RH then
      Radius  := RW
   else
      Radius  := RH;
   dAngle    := FStartAngle + (360 - EndAngle);
   TickAngle := dAngle / (TickCount-1);
   for i := 0 to TickCount-1 do
   begin
      Angle := FStartAngle - i * TickAngle;
      if (i mod FEnlargeEvery) = 0 then
          DrawAngledLine(Angle, Radius - FSize, Radius)
      else
          if FOrigin = soInner then
             DrawAngledLine(Angle, Radius - FSize, Radius - FSize / 2 + 1)
          else
             DrawAngledLine(Angle, Radius - FSize / 2, Radius);
   end;
   if Connect then
   begin
      if FOrigin = soOuter then
         ConnRad := Radius
      else
         ConnRad := Radius - FSize;
      CalcPoint(OrigX,OrigY,0,ConnRad,ConnRect.Right,Temp);
      CalcPoint(OrigX,OrigY,180,ConnRad,ConnRect.Left,Temp);
      CalcPoint(OrigX,OrigY,90,ConnRad,Temp,ConnRect.Top);
      CalcPoint(OrigX,OrigY,270,ConnRad,Temp,ConnRect.Bottom);
      ScaleArc(ConnRect.Left,ConnRect.Top,ConnRect.Right,ConnRect.Bottom,StartAngle,EndAngle,ConnRad);
   end;
end;
{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.NeedCanvas;
begin
   if Canvas = nil then
      { TODO: Should be resource id }
      raise EMMScaleError.Create('Canvas needed for this operation');
end;
{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.ScaleLine(X1, Y1, X2, Y2: Integer; Color: TColor);
var
   Slope     : Float;
   dY, dX    : Integer;
   Sign      : Integer;
   YInc, XInc: Integer;
begin
   dY := -(Y2 - Y1);
   dX := X2 - X1;
   NeedCanvas;
   with Canvas do
   if FStyle = stColor then
   begin
      Pen.Color := Color;
      MoveTo(X1,Y1);
      LineTo(X2,Y2);
   end
   else
   begin
      if Style = stLowered then
         Pen.Color := clBlack
      else
         Pen.Color := clWhite;
      MoveTo(X1,Y1);
      LineTo(X2,Y2);
      if Style = stLowered then
         Pen.Color := clWhite
      else
         Pen.Color := clBlack;
      if dX = 0 then
         dX := dY; { Make it work }
      Slope := dY / dX;
      if Slope >= 0 then
         Sign := 1
      else
         Sign := -1;
      XInc := 0;
      YInc := 0;
      if Abs(dY) >= Abs(dX) then
         XInc := Sign
      else
         YInc := 1;
      MoveTo(X1+XInc,Y1+YInc);
      LineTo(X2+XInc,Y2+YInc);
   end;
end;
{-- TMMCustomScale -------------------------------------------------------}
procedure TMMCustomScale.ScaleArc(X1,Y1,X2,Y2,StAngle,EnAngle: Integer; Radius: Float);
var
   XC, YC  : Float;
   X3, Y3  : Integer;
   X4, Y4  : Integer;
   Angle   : Integer;
   Next    : Integer;
   Horz    : Boolean;
   NextLast: Integer;
   function HorzAngle(Angle: Integer; var NextAngle: Integer): Boolean;
   begin
      while Angle >= 360 do Angle := Angle - 360;
      while Angle < 0 do Angle := Angle + 360;
      Result := False;
      if InRange(Angle,46,135) then
      begin
         NextAngle := 45;
         Result    := False;
      end;
      if InRange(Angle,136,225) then
      begin
         NextAngle := 135;
         Result    := True;
      end;
      if InRange(Angle,226,315) then
      begin
         NextAngle := 225;
         Result    := False;
      end;
      if InRange(Angle,316,360) or InRange(Angle,0,45) then
      begin
         NextAngle := 315;
         Result    := True;
      end;
   end;
   procedure SubArc(A1, A2: Integer; Horz: Boolean);
   var
      XA1, YA1, XA2, YA2: Integer;
   begin
      CalcPoint(XC,YC,A2,Radius,XA1,YA1);
      CalcPoint(XC,YC,A1,Radius,XA2,YA2);
      if Horz then
         Canvas.Arc(X1+1,Y1,X2+1,Y2,XA1+1,YA1,XA2+1,YA2)
      else
         Canvas.Arc(X1,Y1+1,X2,Y2+1,XA1,YA1+1,XA2,YA2+1);
   end;
begin
   XC := (X2 - X1) / 2 + X1;
   YC := (Y2 - Y1) / 2 + Y1;
   CalcPoint(XC,YC,StAngle,Radius,X4,Y4);
   CalcPoint(XC,YC,EnAngle,Radius,X3,Y3);
   with Canvas do
   if Style = stColor then
   begin
      Pen.Color := Color;
      Arc(X1,Y1,X2,Y2,X3,Y3,X4,Y4);
   end
   else
   begin
      if Style = stLowered then
         Pen.Color := clBlack
      else
         Pen.Color := clWhite;
      Arc(X1,Y1,X2,Y2,X3,Y3,X4,Y4);
      if Style = stLowered then
         Pen.Color := clWhite
      else
         Pen.Color := clBlack;
      HorzAngle(EnAngle,NextLast);
      Angle  := StAngle;
      while True do
      begin
         Horz := HorzAngle(Angle,Next);
         if (Next = NextLast) or (Next = EnAngle) then
         begin
            SubArc(Angle,EnAngle,Horz);
            Break;
         end
         else SubArc(Angle,Next,Horz);
         Angle   := Next;
      end;
   end;
end;
end.

						