Delphi控件源码

开发平台：
Delphi

MMEGauge.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.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: 15.11.98 - 03:12:16 $                                        =}
{========================================================================}
Unit MMEGauge;
{$I COMPILER.INC}
Interface
Uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    Menus,
    MMUtils,
    MMString,
    MMObj,
    MMMulDiv,
    MMDIBCv;
const
    VALUERANGE      = 100; { Range for SetValue/GetValue, here 0..100%    }
type
    TMMLEDGaugeKind      = (gkHorizontal, gkVertical);
    TMMLEDGaugeDirection = (dirNormal, dirReversed);
    TMMLEDDrawBar        = procedure(Sender: TObject; DIB: TMMDIBCanvas;
                                     Rect: TRect; nSpots: integer) of object;
    {-- TMMLEDGauge ---------------------------------------------------------}
    TMMLEDGauge = class(TMMDIBGraphicControl)
    private
      FBarDIB       : TMMDIBCanvas; { bitmap for inactive spots            }
      FKind         : TMMLEDGaugeKind; { draw horizontal / vertikal bars      }
      FBar1Color    : TColor;       { Farbe f黵 die Punkte im 1. Abschnitt }
      FBar2Color    : TColor;       { Farbe f黵 die Punkte im 2. Abschnitt }
      FBar3Color    : TColor;       { Farbe f黵 die Punkte im 3. Abschnitt }
      FInact1Color  : TColor;       { foreColor for inactive spots 1       }
      FInact2Color  : TColor;       { foreColor for inactive spots 2       }
      FInact3Color  : TColor;       { foreColor for inactive spots 3       }
      FInactiveDoted: Boolean;      { draw the inactive spots doted        }
      FActiveDoted  : Boolean;      { draw the active spots doted          }
      FPoint1       : integer;      { Schwelle von 1. zu 2. Abschnitt %    }
      FPoint2       : integer;      { Schwelle von 2. zu 3. Abschnitt %    }
      FPoint1Spot   : integer;      { on which spot begins next color      }
      FPoint2Spot   : integer;      { on which spot begins next color      }
      FSpotSpace    : integer;      { Horizontal space between spots       }
      FSpotWidth    : integer;      { the spot width in pixel              }
      FFirstSpace   : integer;      { the space before the first spot      }
      FNumSpots     : integer;      { number of Spots                      }
      FDirection    : TMMLEDGaugeDirection;{ draw direction, forward/backward }
      FProgress     : integer;
      FData         : integer;      { the current data for the gauge       }
      FWidth        : integer;      { calculated width without border      }
      FHeight       : integer;      { calculated height without border     }
      FClientRect   : TRect;        { calculated beveled Rect              }
      FTag2         : integer;
      FOnDrawBar    : TMMLEDDrawBar;
      procedure AdjustSize(var W, H: Integer);
      procedure CalcNumSpots;
      procedure DrawInactiveSpots;
      procedure DrawBarHorizontal(DIB: TMMDIBCanvas; nSpots: integer);
      procedure DrawBarVertical(DIB: TMMDIBCanvas; nSpots: integer);
      procedure DrawBar(Dummy: Boolean);
      procedure SetOnDrawBar(aValue: TMMLEDDrawBar);
      procedure SetKind(aValue: TMMLEDGaugeKind);
      Procedure SetColors(Index: Integer; aValue: TColor);
      procedure SetPoints(Index, aValue: integer);
      procedure SetSpotSpace(aValue: integer);
      procedure SetSpotWidth(aValue: integer);
      procedure SetDirection(aValue: TMMLEDGaugeDirection);
      procedure SetInactiveDoted(aValue: Boolean);
      procedure SetActiveDoted(aValue: Boolean);
      procedure SetProgress(aValue: integer);
      procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    protected
      procedure SetBPP(aValue: integer); override;
      procedure Paint; override;
      procedure Loaded; override;
      procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
      procedure Changed; override;
    public
      constructor Create(AOwner: TComponent); override;
      destructor  Destroy; override;
      property    NumSpots: integer read FNumSpots;
      property    Point1Spot: integer read FPoint1Spot;
      property    Point2Spot: integer read FPoint2Spot;
    published
      property OnClick;
      property OnDblClick;
      property OnMouseDown;
      property OnMouseMove;
      property OnMouseUp;
      property OnDragDrop;
      property OnDragOver;
      property OnEndDrag;
      property OnStartDrag;
      property OnDrawBar: TMMLEDDrawBar read FOnDrawBar write SetOnDrawBar;
      property Align;
      property Bevel;
      property PopupMenu;
      property ParentShowHint;
      property ShowHint;
      property Visible;
      property Enabled;
      property DragCursor;
      property ParentColor default False;
      property Color default clBlack;
      property Kind: TMMLEDGaugeKind read FKind write SetKind default gkHorizontal;
      property Height default 17;
      property Width default 200;
      property SpotSpace: integer read FSpotSpace write SetSpotSpace default 1;
      property SpotWidth: integer read FSpotWidth write SetSpotWidth default 1;
      property Bar1Color: TColor index 0 read FBar1Color write SetColors default clAqua;
      property Bar2Color: TColor index 1 read FBar2Color write SetColors default clAqua;
      property Bar3Color: TColor index 2 read FBar3Color write SetColors default clRed;
      property Inactive1Color: TColor index 3 read FInact1Color write SetColors default clTeal;
      property Inactive2Color: TColor index 4 read FInact2Color write SetColors default clTeal;
      property Inactive3Color: TColor index 5 read FInact3Color write SetColors default clMaroon;
      property InactiveDoted: Boolean read FInactiveDoted write SetInactiveDoted default False;
      property ActiveDoted: Boolean read FActiveDoted write SetActiveDoted default False;
      property Point1: integer index 0 Read FPoint1 write SetPoints default 50;
      property Point2: integer index 1 Read FPoint2 write SetPoints default 85;
      property Direction: TMMLEDGaugeDirection read FDirection write SetDirection default dirNormal;
      property Progress: integer read FProgress write SetProgress default 0;
      property Tag2: integer read FTag2 write FTag2;
    end;
implementation
{-- TMMLEDGauge ------------------------------------------------------}
constructor TMMLEDGauge.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FBarDIB := TMMDIBCanvas.Create(Self);
   FKind := gkHorizontal;
   FDirection := dirNormal;
   FBar1Color := clAqua;
   FBar2Color := clAqua;
   FBar3Color := clRed;
   FInact1Color := clTeal;
   FInact2Color := clTeal;
   FInact3Color := clMaroon;
   FInactiveDoted := False;
   FActiveDoted := False;
   FSpotSpace := 1;
   FSpotWidth := 1;
   FProgress  := 0;
   FData := 0;
   FPoint1 := 50;
   FPoint2 := 85;
   Height := 17;
   Width := 200;
   Color := clBlack;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMLEDGauge ------------------------------------------------------}
Destructor TMMLEDGauge.Destroy;
begin
   FBarDIB.Free;
   inherited Destroy;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetKind(aValue: TMMLEDGaugeKind);
var
   Temp: integer;
begin
   if (aValue <> FKind) then
   begin
      FKind := aValue;
      if ((FKind = gkHorizontal) and (Height > Width)) or
         ((FKind = gkVertical) and (Height < Width)) then
      begin
         Temp := Width;
         Width := Height;                        { swap Width and Height }
         Height := Temp;
      end;
      Changed;                                    { recalc the dimension }
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetDirection(aValue: TMMLEDGaugeDirection);
Begin
   if (aValue <> FDirection) then
   begin
      FDirection := aValue;
      DrawInactiveSpots;
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetSpotSpace(aValue: integer);
begin
   aValue := MinMax(aValue, 0, 10);
   if (aValue <> FSpotSpace) then
   begin
      FSpotSpace := aValue;
      CalcNumSpots;
      Invalidate;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK3}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetSpotWidth(aValue: integer);
Var
   Temp: integer;
begin
   Temp := 0;
   case FKind of
      gkHorizontal: Temp := FWidth div 3;
      gkVertical  : Temp := FHeight div 3;
   end;
   aValue := MinMax(aValue, 1, Temp);
   if (aValue <> FSpotWidth) then
   begin
      FSpotWidth := aValue;
      CalcNumSpots;
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.CalcNumSpots;
begin
   FSpotWidth := Max(FSpotWidth,1);
   if (FKind = gkHorizontal) then
   begin
      FNumSpots := (FWidth+FSpotSpace) div (FSpotWidth+FSpotSpace);
      FNumSpots := Max(FNumSpots,1);          { fix div by zerro !!! }
      FFirstSpace := (FWidth-(FNumSpots*(FSpotWidth+FSpotSpace)-FSpotSpace)) div 2;
   end
   else
   begin
      FNumSpots := (FHeight+FSpotSpace)div(FSpotWidth+FSpotSpace);
      FNumSpots := Max(FNumSpots,1);           { fix div by zerro !!! }
      FFirstSpace := (FHeight-(FNumSpots*(FSpotWidth+FSpotSpace)-FSpotSpace)) div 2;
   end;
   { calc the spot on which the next color starts }
   FPoint1Spot := (FPoint1 * FNumSpots) div 100;
   FPoint2Spot := (FPoint2 * FNumSpots) div 100;
   { redraw background }
   DrawInactiveSpots;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.AdjustSize(var W, H: Integer);
begin
   if not (csLoading in ComponentState) then
   begin
      W := Max(W,2*BevelExtend+2);
      H := Max(H,2*BevelExtend);
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
var
  W, H: Integer;
begin
   W := aWidth;
   H := aHeight;
   AdjustSize (W, H);
   inherited SetBounds(aLeft, aTop, W, H);
   Changed;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.Loaded;
var
  W, H: Integer;
begin
   inherited Loaded;
   W := Width;
   H := Height;
   AdjustSize(W, H);
   Width := W;
   Height:= H;
   DrawInactiveSpots;
   Invalidate;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.Changed;
begin
   FClientRect := BeveledRect;
   FWidth  := Max(FClientRect.Right - FClientRect.Left,1);
   FHeight := Max(FClientRect.Bottom - FClientRect.Top,1);
   DIBCanvas.SetBounds(0,0,FWidth,FHeight);
   FBarDIB.SetBounds(0,0,FWidth,FHeight);
   { recalculate the number of spots }
   CalcNumSpots;
   inherited Changed;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetPoints(Index, aValue: integer);
begin
   aValue := MinMax(aValue, 1, 100);
   case Index of
     0: if FPoint1 = aValue then exit else FPoint1 := aValue;
     1: if FPoint2 = aValue then exit else FPoint2 := aValue;
   end;
   CalcNumSpots;
   Invalidate;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetColors(Index:Integer; aValue: TColor);
begin
   case Index of
      0: if FBar1Color = aValue then exit else FBar1Color := aValue;
      1: if FBar2Color = aValue then exit else FBar2Color := aValue;
      2: if FBar3Color = aValue then exit else FBar3Color := aValue;
      3: if FInact1Color = aValue then exit else FInact1Color := aValue;
      4: if FInact2Color = aValue then exit else FInact2Color := aValue;
      5: if FInact3Color = aValue then exit else FInact3Color := aValue;
   end;
   DrawInactiveSpots;
   Invalidate;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetInactiveDoted(aValue: Boolean);
begin
   if (aValue <> FInactiveDoted) then
   begin
      FInactiveDoted := aValue;
      DrawInactiveSpots;
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetActiveDoted(aValue: Boolean);
begin
   if (aValue <> FActiveDoted) then
   begin
      FActiveDoted := aValue;
      DrawInactiveSpots;
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.CMColorChanged(var Message: TMessage);
begin
   DrawInactiveSpots;
   inherited;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetProgress(aValue: integer);
begin
   if (aValue <> FProgress) then
   begin
      FProgress := MinMax(aValue,0,VALUERANGE);
      FData     := Min(MulDiv32(FProgress,FNumSpots,VALUERANGE),FNumSpots);
      if (csDesigning in ComponentState) then
          Refresh
      else
          FastDraw(DrawBar,False);
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.DrawBarHorizontal(DIB: TMMDIBCanvas; nSpots: integer);
Var
   i: integer;
   SpotRect: TRect;                                 { Spot draw rectangle }
   SpotInc: integer;                       { increase value for next spot }
begin
   SpotInc := FSpotWidth + FSpotSpace;
   SpotRect.Top := 0;
   SpotRect.Bottom := FHeight;
   if (FDirection = dirNormal) then
   begin
      SpotRect.Left := FFirstSpace;
      SpotRect.Right := SpotRect.Left + FSpotWidth;             {Leerraum }
   end
   else
   begin
      SpotRect.Right := FWidth - FFirstSpace;
      SpotRect.Left := SpotRect.Right - FSpotWidth;
      SpotInc := -SpotInc;
   end;
   with DIB do
   begin
      DIB_SetTColor(FBar1Color);
      for i := 1 to nSpots do                  { draw the highlited spots }
      begin
         if i > FPoint2Spot then DIB_SetTColor(FBar3Color)
         else if i > FPoint1Spot then DIB_SetTColor(FBar2Color);
         DIB_FillRectDoted(SpotRect,FActiveDoted);
         OffsetRect(SpotRect, SpotInc, 0);
      end;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.DrawBarVertical(DIB: TMMDIBCanvas; nSpots: integer);
Var
   i: integer;
   SpotRect: TRect;                                 { Spot draw rectangle }
   SpotInc: integer;                       { increase value for next spot }
begin
   SpotInc := FSpotWidth + FSpotSpace;
   SpotRect.Left := 0;
   SpotRect.Right := FWidth;
   with DIB do
   begin
      if (FDirection = dirNormal) then
      begin
         SpotRect.Bottom := FHeight - FFirstSpace;
         SpotRect.Top := SpotRect.Bottom - FSpotWidth;
         SpotInc := -SpotInc;
      end
      else
      begin
         SpotRect.Top := FFirstSpace;
         SpotRect.Bottom := SpotRect.Top + FSpotWidth;
      end;
      DIB_SetTColor(FBar1Color);
      for i := 1 to nSpots do                 { draw the highlited spots }
      begin
         if i > FPoint2Spot then DIB_SetTColor(FBar3Color)
         else if i > FPoint1Spot then DIB_SetTColor(FBar2Color);
         DIB_FillRectDoted(SpotRect,FActiveDoted);
         OffsetRect(SpotRect, 0, SpotInc);
      end;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetBPP(aValue: integer);
begin
   if (aValue <> BitsPerPixel) then
   begin
      if (aValue <> 8) and (aValue <> 24) then
         raise EMMDIBError.Create('Bitlength not supported yet');
      FBarDIB.BitsPerPixel := aValue;
      DIBCanvas.BitsPerPixel := aValue;
      DrawInactiveSpots;
      Invalidate;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.DrawInactiveSpots;
var
   _Bar1,_Bar2,_Bar3: TColor;
   _Active: Boolean;
begin
   if not (csLoading in ComponentState) and (FBarDIB <> nil) and not assigned(FOnDrawBar) then
   with FBarDIB do
   begin
      DIB_InitDrawing;
      DIB_SetTColor(Color);
      DIB_Clear;
      _Bar1 := FBar1Color;
      _Bar2 := FBar2Color;
      _Bar3 := FBar3Color;
      _Active := FActiveDoted;
      FBar1Color := FInact1Color;
      FBar2Color := FInact2Color;
      FBar3Color := FInact3Color;
      FActiveDoted := FInactiveDoted;
      case FKind of
         gkHorizontal: DrawBarHorizontal(FBarDIB,FNumSpots);
         gkVertical  : DrawBarVertical(FBarDIB,FNumSpots);
      end;
      FBar1Color := _Bar1;
      FBar2Color := _Bar2;
      FBar3Color := _Bar3;
      FActiveDoted := _Active;
      DIB_DoneDrawing;
   end;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.SetOnDrawBar(aValue: TMMLEDDrawBar);
begin
   FOnDrawBar := aValue;
   if not assigned(FOnDrawBar) then DrawInactiveSpots;
   Invalidate;
end;
{-- TMMLEDGauge ------------------------------------------------------}
procedure TMMLEDGauge.DrawBar(Dummy: Boolean);
begin
   DIBCanvas.DIB_InitDrawing;
   if assigned(FOnDrawBar) then
   begin
      FOnDrawBar(Self,DIBCanvas,Rect(0,0,FWidth,FHeight),FData);
   end
   else
   begin                                         { draw the background }
      DIBCanvas.DIB_SetTColor(Color);
      DIBCanvas.DIB_Clear;
      DIBCanvas.DIB_CopyDIBBits(FBarDIB.Surface,0,0,FWidth,FHeight,0,0);
      case FKind of                           { draw the bar to bitmap }
          gkHorizontal: DrawBarHorizontal(DIBCanvas,FData);
          gkVertical  : DrawBarVertical(DIBCanvas,FData);
      end;
   end;
   DIBCanvas.DIB_BitBlt(Canvas.Handle,FClientRect,0,0); { copy to screen }
   DIBCanvas.DIB_DoneDrawing;
end;
{-- TMMLEDGauge ------------------------------------------------------}
Procedure TMMLEDGauge.Paint;
begin
   { draw the bevel }
   inherited Paint;
   DrawBar(True);
end;
end.

						