有3D效果的进度条

// The Unofficial Newsletter of Delphi Users - Issue #12 - February 23rd, 1996  

unit Percnt3d; 

(* 

   TPercnt3D by Lars Posthuma; December 26, 1995. 

   Copyright 1995, Lars Posthuma. 

   All rights reserved. 

   This source code may be freely distributed and used. The author 

   accepts no responsibility for its use or misuse. 

   No warranties whatsoever are offered for this unit. 

   If you make any changes to this source code please inform me at: 

   LPosthuma@COL.IB.COM. 

*) 

interface 

uses 

  WinTypes, WinProcs, Classes, Graphics, Controls, ExtCtrls, Forms, SysUtils, Dialogs; 

type 

  TPercnt3DOrientation = (BarHorizontal,BarVertical); 

  TPercnt3D = class(TCustomPanel) 

    private 

      { Private declarations } 

      fProgress    : Integer; 

      fMinValue    : Integer; 

      fMaxValue    : Integer; 

      fShowText    : Boolean; 

      fOrientation : TPercnt3DOrientation; 

      fHeight      : Integer; 

      fWidth       : Integer; 

      fValueChange : TNotifyEvent; 

      procedure SetBounds(Left,Top,fWidth,fHeight: integer); override; 

      procedure SetHeight(value: Integer); virtual; 

      procedure SetWidth(value: Integer); virtual; 

      procedure SetMaxValue(value: Integer); virtual; 

      procedure SetMinValue(value: Integer); virtual; 

      procedure SetProgress(value: Integer); virtual; 

      procedure SetOrientation(value: TPercnt3DOrientation); 

      procedure SetShowText(value: Boolean); 

      function GetPercentDone: Longint; 

    protected 

      { Protected declarations } 

      procedure Paint; override; 

    public 

      { Public declarations } 

      constructor Create(AOwner: TComponent); override; 

      destructor Destroy; override; 

      procedure AddProgress(Value: Integer); 

      property PercentDone: Longint read GetPercentDone; 

      procedure SetMinMaxValue(Minvalue,MaxValue: Integer); 

    published 

      { Published declarations } 

      property Align; 

      property Cursor; 

      property Color default clBtnFace; 

      property Enabled; 

      property Font; 

      property Height default ; 

      property Width default ; 

      property MaxValue: Integer 

               read fMaxValue write SetMaxValue 

               default ; 

      property MinValue: Integer 

               read fMinValue write SetMinValue 

               default ; 

      property Progress: Integer 

               read fProgress write SetProgress 

               default ; 

      property ShowText: Boolean 

               read fShowText write SetShowText 

               default True; 

      property Orientation: TPercnt3DOrientation             {} 

               read fOrientation write SetOrientation 

               default BarHorizontal; 

      property OnValueChange: TNotifyEvent                   {Userdefined Method} 

               read fValueChange write fValueChange; 

      property Visible; 

      property Hint; 

      property ParentColor; 

      property ParentFont; 

      property ParentShowHint; 

      property ShowHint; 

      property Tag; 

      property OnClick; 

      property OnDragDrop; 

      property OnDragOver; 

      property OnEndDrag; 

      property OnMouseDown; 

      property OnMouseMove; 

      property OnMouseUp; 

  end; 

procedure Register; 

implementation 

constructor TPercnt3D.Create(AOwner: TComponent); 

begin 

 inherited Create(AOwner); 

 Color       := clBtnFace;                       {Set initial (default) values} 

 Height      := ; 

 Width       := ; 

 fOrientation := BarHorizontal; 

 Font.Color  := clBlue; 

 Caption     := ' '; 

 fMinValue   := ; 

 fMaxValue   := ; 

 fProgress   := ; 

 fShowText   := True; 

end; 

destructor TPercnt3D.Destroy; 

begin 

 inherited Destroy 

end; 

procedure TPercnt3D.SetHeight(value: integer); 

begin 

 if value <> fHeight then begin 

   fHeight:= value; 

   SetBounds(Left,Top,Width,fHeight); 

   Invalidate; 

 end 

end; 

procedure TPercnt3D.SetWidth(value: integer); 

begin 

 if value <> fWidth then begin 

   fWidth:= value; 

   SetBounds(Left,Top,fWidth,Height); 

   Invalidate; 

 end 

end; 

procedure TPercnt3D.SetBounds(Left,Top,fWidth,fHeight : integer); 

 Procedure SwapWH(Var Width, Height: Integer); 

 Var 

  TmpInt: Integer; 

 begin 

  TmpInt:= Width; 

  Width := Height; 

  Height:= TmpInt; 

 end; 

 Procedure SetMinDims(Var XValue,YValue: Integer; XValueMin,YValueMin: Integer); 

 begin 

  if XValue < XValueMin 

   then XValue:= XValueMin; 

  if YValue < YValueMin 

   then YValue:= YValueMin; 

 end; 

begin 

 case fOrientation of 

   BarHorizontal: begin 

                   if fHeight > fWidth 

                     then SwapWH(fWidth,fHeight); 

                   SetMinDims(fWidth,fHeight,,); 

                  end; 

   BarVertical  : begin 

                   if fWidth > fHeight 

                     then SwapWH(fWidth,fHeight); 

                   SetMinDims(fWidth,fHeight,,); 

                  end; 

 end; 

 inherited SetBounds(Left,Top,fWidth,fHeight); 

end; 

procedure TPercnt3D.SetOrientation(value : TPercnt3DOrientation); 

Var 

 x: Integer; 

begin 

 if value <> fOrientation then begin 

   fOrientation:= value; 

   SetBounds(Left,Top,Height,Width);                       {Swap Width/Height} 

   Invalidate; 

 end 

end; 

procedure TPercnt3D.SetMaxValue(value: integer); 

begin 

 if value <> fMaxValue then begin 

   fMaxValue:= value; 

   Invalidate; 

 end 

end; 

procedure TPercnt3D.SetMinValue(value: integer); 

begin 

 if value <> fMinValue then begin 

   fMinValue:= value; 

   Invalidate; 

 end 

end; 

procedure TPercnt3D.SetMinMaxValue(MinValue, MaxValue: integer); 

begin 

 fMinValue:= MinValue; 

 fMaxValue:= MaxValue; 

 fProgress:= ; 

 Repaint;                                        { Always Repaint } 

end; 

{ This function solves for x in the equation "x is y% of z". } 

function SolveForX(Y, Z: Longint): Integer; 

begin 

 SolveForX:= Trunc( Z * (Y * 0.01) ); 

end; 

{ This function solves for y in the equation "x is y% of z". } 

function SolveForY(X, Z: Longint): Integer; 

begin 

 if Z =  

   then SolveForY:=  

   else SolveForY:= Trunc( (X * ) / Z ); 

end; 

function TPercnt3D.GetPercentDone: Longint; 

begin 

 GetPercentDone:= SolveForY(fProgress - fMinValue, fMaxValue - fMinValue); 

end; 

procedure TPercnt3D.Paint; 

var 

 TheImage: TBitmap; 

 FillSize: Longint; 

 W,H,X,Y : Integer; 

 TheText : string; 

begin 

 with Canvas do begin 

   TheImage:= TBitmap.Create; 

   try 

     TheImage.Height:= Height; 

     TheImage.Width := Width; 

     with TheImage.Canvas do begin 

       Brush.Color:= Color; 

       with ClientRect do begin 

         { Paint the background } 

         { Select Black Pen to outline Window } 

         Pen.Style:= psSolid; 

         Pen.Width:= ; 

         Pen.Color:= clBlack; 

         { Bounding rectangle in black } 

         Rectangle(Left,Top,Right,Bottom); 

         { Draw the inner bevel } 

         Pen.Color:= clGray; 

         Rectangle(Left + , Top + , Right - , Bottom - ); 

         Pen.Color:= clWhite; 

         MoveTo(Left + , Bottom - ); 

         LineTo(Right - , Bottom - ); 

         LineTo(Right - , Top + ); 

         { Draw the 3D Percent stuff } 

         { Outline the Percent Bar in black } 

         Pen.Color:= clBlack; 

         if Orientation = BarHorizontal 

           then w:= Right - Left { + 1; } 

           else w:= Bottom - Top; 

         FillSize:= SolveForX(PercentDone, W); 

         if FillSize >  then begin 

           case orientation of 

            BarHorizontal: begin 

                            Rectangle(Left,Top,FillSize,Bottom); 

                            { Draw the 3D Percent stuff } 

                            { UpperRight, LowerRight, LowerLeft } 

                            Pen.Color:= clGray; 

                            Pen.Width:= ; 

                            MoveTo(FillSize - , Top + ); 

                            LineTo(FillSize - , Bottom - ); 

                            LineTo(Left + , Bottom - ); 

                            { LowerLeft, UpperLeft, UpperRight } 

                            Pen.Color:= clWhite; 

                            Pen.Width:= ; 

                            MoveTo(Left + , Bottom - ); 

                            LineTo(Left + , Top + ); 

                            LineTo(FillSize - , Top + ); 

                           end; 

            BarVertical:   begin 

                            FillSize:= Height - FillSize; 

                            Rectangle(Left,FillSize,Right,Bottom); 

                            { Draw the 3D Percent stuff } 

                            { LowerLeft, UpperLeft, UpperRight } 

                            Pen.Color:= clGray; 

                            Pen.Width:= ; 

                            MoveTo(Left + , FillSize + ); 

                            LineTo(Right - , FillSize + ); 

                            LineTo(Right - , Bottom - ); 

                            { UpperRight, LowerRight, LowerLeft } 

                            Pen.Color:= clWhite; 

                            Pen.Width:= ; 

                            MoveTo(Left + ,FillSize + ); 

                            LineTo(Left + ,Bottom - ); 

                            LineTo(Right - ,Bottom - ); 

                           end; 

           end; 

         end; 

         if ShowText = True then begin 

           Brush.Style:= bsClear; 

           Font       := Self.Font; 

           Font.Color := Self.Font.Color; 

           TheText:= Format('%d%%', [PercentDone]); 

           X:= (Right - Left +  - TextWidth(TheText)) div ; 

           Y:= (Bottom - Top +  - TextHeight(TheText)) div ; 

           TextRect(ClientRect, X, Y, TheText); 

         end; 

       end; 

     end; 

     Canvas.CopyMode:= cmSrcCopy; 

     Canvas.Draw(,,TheImage); 

     finally 

       TheImage.Destroy; 

   end; 

 end; 

end; 

procedure TPercnt3D.SetProgress(value: Integer); 

begin 

 if (fProgress <> value) and (value >= fMinValue) and (value <= fMaxValue) then begin 

   fProgress:= value; 

   Invalidate; 

 end; 

end; 

procedure TPercnt3D.AddProgress(value: Integer); 

begin 

 Progress:= fProgress + value; 

 Refresh; 

end; 

procedure TPercnt3D.SetShowText(value: Boolean); 

begin 

 if value <> fShowText then begin 

   fShowText:= value; 

   Refresh; 

 end; 

end; 

procedure Register; 

begin 

 RegisterComponents('DDG', [TPercnt3D]); 

end; 

end.