Delphi控件源码

开发平台：
Delphi

MMGauge.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: 15.02.98 - 15:32:59 $                                        =}
{========================================================================}
unit MMGauge;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Classes,
    Controls,
    Graphics,
    Menus,
    MMObj;
type
    TMMGaugeKind = (gkText,gkHorizontalBar,gkVerticalBar,gkPie,gkNeedle);
const
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth } {$ENDIF}
    defWidth     = 150;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight } {$ENDIF}
    defHeight    = 18;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defKind } {$ENDIF}
    defKind      = gkHorizontalBar;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defShowText } {$ENDIF}
    defShowText  = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defForeColor } {$ENDIF}
    defForeColor = clActiveCaption;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defBackColor } {$ENDIF}
    defBackColor = clWhite;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defMinValue } {$ENDIF}
    defMinValue  = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defMaxValue } {$ENDIF}
    defMaxValue  = 100;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defProgress } {$ENDIF}
    defProgress  = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defBWText } {$ENDIF}
    defBWText    = False;
type
    {-- TMMCustomGauge --------------------------------------------------}
    TMMCustomGauge  = class(TMMGraphicControl)
    private
        FMinValue   : Longint;
        FMaxValue   : Longint;
        FCurValue   : Longint;
        FKind       : TMMGaugeKind;
        FShowText   : Boolean;
        FForeColor  : TColor;
        FBackColor  : TColor;
        FBWText     : Boolean;
        FCaption    : string;
        procedure   SetGaugeKind(Value: TMMGaugeKind);
        procedure   SetShowText(Value: Boolean);
        procedure   SetForeColor(Value: TColor);
        procedure   SetBackColor(Value: TColor);
        procedure   SetMinValue(Value: Longint);
        procedure   SetMaxValue(Value: Longint);
        procedure   SetProgress(Value: Longint);
        procedure   SetCaption(const Value: string);
        procedure   SetBWText(Value: Boolean);
        function    GetPercentDone: LongInt;
    protected
        procedure   Paint; override;
        procedure   PaintImage(Canvas: TCanvas; R: TRect); virtual;
        procedure   PaintText(Canvas: TCanvas; R: TRect); virtual;
        procedure   PaintAsBar(Canvas: TCanvas; R: TRect; Horz: Boolean); virtual;
        procedure   PaintAsPie(Canvas: TCanvas; R: TRect); virtual;
        procedure   PaintAsNeedle(Canvas: TCanvas; R: TRect); virtual;
        procedure   PaintAsNothing(Canvas: TCanvas; R: TRect); virtual;
    public
        constructor Create(AOwner: TComponent); override;
        procedure   AddProgress(Value: Longint);
        property    PercentDone: Longint read GetPercentDone;
    protected
        property    Width default defWidth;
        property    Height default defHeight;
        property    Kind: TMMGaugeKind read FKind write SetGaugeKind default defKind;
        property    ShowText: Boolean read FShowText write SetShowText default defShowText;
        property    ForeColor: TColor read FForeColor write SetForeColor default defForeColor;
        property    BackColor: TColor read FBackColor write SetBackColor default defBackColor;
        property    MinValue: Longint read FMinValue write SetMinValue default defMinValue;
        property    MaxValue: Longint read FMaxValue write SetMaxValue default defMaxValue;
        property    Progress: Longint read FCurValue write SetProgress default defProgress;
        property    Caption: string read FCaption write SetCaption;
        property    BWText: Boolean read FBWText write SetBWText default defBWText;
    end;
    {-- TMMGauge --------------------------------------------------------}
    TMMGauge        = class(TMMCustomGauge)
    published
        property    Kind;
        property    ShowText;
        property    ForeColor;
        property    BackColor;
        property    MinValue;
        property    MaxValue;
        property    Progress;
        property    Caption;
        property    BWText;
        property    Align;
        property    Enabled;
        property    Font;
        property    Bevel;
        property    ParentFont;
        property    ParentShowHint;
        property    PopupMenu;
        property    ShowHint;
        property    Visible;
    end;
implementation
uses
    SysUtils,
    MMUtils;
{------------------------------------------------------------------------}
{ This function solves for x in the equation "x is y% of z". }
function SolveForX(Y, Z: Longint): Longint;
begin
    Result := Trunc(Z*(Y*0.01));
end;
{------------------------------------------------------------------------}
{ This function solves for y in the equation "x is y% of z". }
function SolveForY(X, Z: Longint): Longint;
begin
    if Z = 0 then
        Result := 0
    else
        Result := Trunc((X*100.0)/Z);
end;
{== TMMCustomGauge ======================================================}
constructor TMMCustomGauge.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    FKind       := defKind;
    FShowText   := defShowText;
    FForeColor  := defForeColor;
    FBackColor  := defBackColor;
    FMinValue   := defMinValue;
    FMaxValue   := defMaxValue;
    FCurValue   := defProgress;
    FBWText     := defBWText;
    Width       := defWidth;
    Height      := defHeight;
    ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
    if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetGaugeKind(Value: TMMGaugeKind);
begin
    if Value <> FKind then
    begin
        FKind := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetShowText(Value: Boolean);
begin
    if Value <> FShowText then
    begin
        FShowText := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetForeColor(Value: TColor);
begin
    if Value <> FForeColor then
    begin
        FForeColor := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetBackColor(Value: TColor);
begin
    if Value <> FBackColor then
    begin
        FBackColor := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure   TMMCustomGauge.SetMinValue(Value: Longint);
begin
    Value := MinMax(Value,-MaxInt,MaxValue);
    if Value <> FMinValue then
    begin
        FMinValue := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetMaxValue(Value: Longint);
begin
    Value := MinMax(Value,MinValue,MaxInt);
    if Value <> FMaxValue then
    begin
        FMaxValue := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetProgress(Value: Longint);
var
    Old: LongInt;
begin
    Value := MinMax(Value,MinValue,MaxValue);
    if Value <> FCurValue then
    begin
        Old       := PercentDone;
        FCurValue := Value;
        if Old <> PercentDone then
           Refresh;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.AddProgress(Value: Longint);
begin
    Progress := FCurValue + Value;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetCaption(const Value: string);
begin
    if Value <> FCaption then
    begin
        FCaption := Value;
        Invalidate;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
function TMMCustomGauge.GetPercentDone: LongInt;
begin
    Result := SolveForY(FCurValue-FMinValue, FMaxValue-FMinValue);
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.Paint;
var
    R: TRect;
    OffScreen: TBitmap;
begin
    R := Bevel.PaintBevel(Canvas,ClientRect,True);
    OffScreen := TBitmap.Create;
    try
        with OffScreen do
        begin
            Width := R.Right  - R.Left;
            Height:= R.Bottom - R.Top;
            PaintImage(Canvas,Bounds(0,0,Width,Height));
            if FShowText then
                PaintText(Canvas,Bounds(0,0,Width,Height));
        end;
        Canvas.Draw(R.Left,R.Top,OffScreen);
    finally
        OffScreen.Free;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintImage(Canvas: TCanvas; R: TRect);
begin
    case FKind of
        gkHorizontalBar, gkVerticalBar: PaintAsBar(Canvas,R,FKind = gkHorizontalBar);
        gkPie: PaintAsPie(Canvas,R);
        gkNeedle: PaintAsNeedle(Canvas,R);
    else
        PaintAsNothing(Canvas,R);
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintText(Canvas: TCanvas; R: TRect);
var
    TextBmp : TBitmap;
    Text    : string;
    OldMode : TCopyMode;
    X, Y    : Integer;
    X2, Y2  : Integer;
begin
    if Caption <> '' then
        Text := Format('%s %d%%',[Caption,PercentDone])
    else
        Text := Format('%d%%',[PercentDone]);
    if (((Kind = gkHorizontalBar) or (Kind = gkVerticalBar))) and BWText then
    begin
        Canvas.Font := Self.Font;
        X  := R.Left + (R.Right - R.Left - Canvas.TextWidth(Text)) div 2;
        Y  := R.Top + (R.Bottom - R.Top - Canvas.TextHeight(Text)) div 2;
        X2 := R.Left + SolveForX(PercentDone,R.Right-R.Left);
        Y2 := R.Bottom - SolveForX(PercentDone,R.Bottom-R.Top);
        Canvas.Brush.Style := bsClear;
        if Kind = gkHorizontalBar then
            Canvas.TextRect(Rect(X2,Y,R.Right,R.Bottom),X,Y,Text)
        else
            Canvas.TextRect(Rect(X,Y,R.Right,Y2),X,Y,Text);
        Canvas.Font.Color := ColorToRGB(clWhite) xor Self.Font.Color;
        if Kind = gkHorizontalBar then
            Canvas.TextRect(Rect(X,Y,X2,R.Bottom),X,Y,Text)
        else
            Canvas.TextRect(Rect(X,Y2,R.Right,R.Bottom),X,Y,Text);
    end
    else
    begin
        TextBmp := TBitmap.Create;
        try
            with TextBmp do
            begin
                Width       := R.Right - R.Left;
                Height      := R.Bottom - R.Top;
                Canvas.Brush.Color := clBlack;
                Canvas.FillRect(Bounds(0,0,Width,Height));
                Canvas.Font := Self.Font;
                Canvas.Font.Color := clWhite;
                X := (Width - Canvas.TextWidth(Text)) div 2;
                Y := (Height - Canvas.TextHeight(Text)) div 2;
                Canvas.TextOut(X, Y, Text);
            end;
            OldMode := Canvas.CopyMode;
            try
                Canvas.CopyMode := cmSrcInvert;
                Canvas.Draw(R.Left,R.Top,TextBmp);
            finally
                Canvas.CopyMode := OldMode;
            end;
        finally
            TextBmp.Free;
        end;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintAsBar(Canvas: TCanvas; R: TRect; Horz: Boolean);
var
    FillSize: Integer;
    W, H    : Integer;
begin
    with Canvas do
    begin
        Brush.Color := BackColor;
        FillRect(R);
        Brush.Color := ForeColor;
        Pen.Width   := 1;
        Pen.Color   := ForeColor;
        W           := R.Right - R.Left;
        H           := R.Bottom - R.Top;
        if Horz then
        begin
            FillSize := SolveForX(PercentDone,W);
            if FillSize > 0 then
                FillRect(Bounds(R.Left,R.Top,FillSize,H));
        end
        else
        begin
            FillSize := SolveForX(PercentDone,H);
            if FillSize > 0 then
                FillRect(Bounds(R.Left,R.Top+H-FillSize,W,FillSize));
        end;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintAsPie(Canvas: TCanvas; R: TRect);
var
    MiddleX, MiddleY: Integer;
    Angle           : Double;
    W, H            : Integer;
begin
    W := R.Right - R.Left;
    H := R.Bottom - R.Top;
    with Canvas do
    begin
        Brush.Color := Color;
        FillRect(R);
        Brush.Color := BackColor;
        Pen.Color := ForeColor;
        Pen.Width := 1;
        Ellipse(R.Left, R.Top, W, H);
        if PercentDone > 0 then
        begin
            Brush.Color := ForeColor;
            MiddleX := W div 2;
            MiddleY := H div 2;
            Angle := (Pi * ((PercentDone / 50) + 0.5));
            Pie(R.Left, R.Top, W, H,
                Round(MiddleX * (1 - Cos(Angle))),Round(MiddleY * (1 - Sin(Angle))),
                MiddleX, 0);
        end;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintAsNeedle(Canvas: TCanvas; R: TRect);
var
    MiddleX     : Integer;
    Angle       : Double;
    X, Y, W, H  : Integer;
begin
    with R do
    begin
        X := Left;
        Y := Top;
        W := Right - Left;
        H := Bottom - Top;
    end;
    with Canvas do
    begin
        Brush.Color := Color;
        FillRect(R);
        Brush.Color := BackColor;
        Pen.Color := ForeColor;
        Pen.Width := 1;
        Pie(X, Y, W, H * 2 - 1, X + W, R.Bottom - 1, X, R.Bottom - 1);
        MoveTo(X, R.Bottom);
        LineTo(X + W, R.Bottom);
        if PercentDone > 0 then
        begin
            Pen.Color := ForeColor;
            MiddleX := Width div 2;
            MoveTo(MiddleX, R.Bottom - 1);
            Angle := (Pi * ((PercentDone / 100)));
            LineTo(Round(MiddleX * (1 - Cos(Angle))),
                   Round((R.Bottom - 1)*(1 - Sin(Angle))));
        end;
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.PaintAsNothing(Canvas: TCanvas; R: TRect);
begin
    with Canvas do
    begin
        Brush.Color := BackColor;
        FillRect(R);
    end;
end;
{-- TMMCustomGauge ------------------------------------------------------}
procedure TMMCustomGauge.SetBWText(Value: Boolean);
begin
    if Value <> FBWText then
    begin
        FBWText := Value;
        Invalidate;
    end;
end;
end.

						