mmscale.pas

一套及时通讯的原码

         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.