skyguage.pas

很好用的 比自代的好用多了 请看说明

{*****************************************************************************
*                      新风格进度条控件 - TSkyGauge                          *
*                                                                            *
*   功能： 提供与系统进度条显示风格不一样的感觉 ^o^                          *
*   版本： V1.01                                                             *
*   作者： 顾中军                                                            *
*   日期:  2006.8.27 ~ 2006.8.29 完成                                        *
*   用法：                                                                   *
*          很简单，设置好各参数即可看到效果                                  *
*   说明：                                                                   *
*       最近想在自己写的软件里加上一些进度显示效果，但Delphi提供的标准进度条 *
*   及Samples中的Guage的效果实在太单调，所以用了三个晚上的时间自己写了一个。 *
*       这个东东比较有特色的地方是可以使用渐变色来显示进度；如果你觉得这还不 *
*   够，那么你还可以使用图片！这下可以得到华丽的效果了，呵呵……             *
*       祝你愉快！！！                                                       *
*                                                                            *
*   Email:     [e-mail]                                             *
*****************************************************************************}

unit SkyGuage;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Graphics;

type
  TSkyGuage = class(TCustomControl)
  private
    { Private declarations }
    FAutoResume: Boolean;  //自动回绕 ?
    FUseShade:   Boolean;  //使用渐变色 ?
    FDrawFrame:  Boolean;  //画边框 ?
    FKeepSpace:  Boolean;  //边框与进度区之间保留空白 ?
    FUseGraph:   Boolean;  //使用图片 ?
    FShowPer:    Boolean;  //显示百分比 ?
    FMin,
    FMax,
    FProgress,
    FStep:       Integer;
    FBackColor,
    FForeColor,
    FFrameColor,
    FShadeColor: TColor;
    FBmpBuf:     TBitmap;  //缓冲位图
    FBackGraph:  TBitmap;  //背景位图
    FForeGraph:  TBitmap;  //前景位图
    procedure SetMin(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetProgress(Value: Integer);
    procedure SetStep(Value: Integer);
    procedure SetBackColor(Value: TColor);
    procedure SetForeColor(Value: TColor);
    procedure SetFrameColor(Value: TColor);
    procedure SetUseShade(Value: Boolean);
    procedure SetShadeColor(Value: TColor);
    procedure SetDrawFrame(Value: Boolean);
    procedure SetKeepSpace(Value: Boolean);
    procedure SetUseGraph(Value: Boolean);
    function GetBackGraph: TGraphic;
    procedure SetBackGraph(Value: TGraphic);
    function GetForeGraph: TGraphic;
    procedure SetForeGraph(Value: TGraphic);
    procedure SetShowPer(Value: Boolean);
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure DoDrawFrame(ACanvas: TCanvas; ARect: TRect);
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StepIt(iLength: Integer = 1);
  published
    { Published declarations }
    property AutoResume: Boolean read FAutoResume write FAutoResume default False;
    property UseShade: Boolean read FUseShade write SetUseShade default False;
    property DrawFrame: Boolean read FDrawFrame write SetDrawFrame default True;
    property KeepSpace: Boolean read FKeepSpace write SetKeepSpace default True;
    property UseGraph: Boolean read FUseGraph write SetUseGraph default False;
    property ShowPercent: Boolean read FShowPer write SetShowPer default False;
    property Min: Integer read FMin write SetMin default 0;
    property Max: Integer read FMax write SetMax default 100;
    property Progress: Integer read FProgress write SetProgress default 0;
    property Step: Integer read FStep write SetStep default 40;
    property BackColor: TColor  read FBackColor  write SetBackColor  default clBtnFace;
    property ForeColor: TColor  read FForeColor  write SetForeColor  default clBlue;
    property FrameColor: TColor read FFrameColor write SetFrameColor default clNavy;
    property ShadeColor: TColor read FShadeColor write SetShadeColor default clWhite;
    property BackGraph: TGraphic read GetBackGraph write SetBackGraph;
    property ForeGraph: TGraphic read GetForeGraph write SetForeGraph;

    property Action;
    property Align;
    property Constraints;
    property Ctl3D;
    property Font;
    property PopupMenu;
    property ShowHint;
    property Visible;

    property OnCanResize;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDockDrop;
    property OnDockOver;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TSkyGuage]);
end;

{ TSkyGuage }

constructor TSkyGuage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width     := 200;
  Height    := 20;
  FDrawFrame:= True;
  FKeepSpace:= True;
  FMin      := 0;
  FMax      := 100;
  FProgress := 0;
  FStep     := 40;
  FBackColor  := clBtnFace;
  FForeColor  := clBlue;
  FFrameColor := clNavy;
  FShadeColor := clWhite;
  FBmpBuf     := TBitmap.Create;
  FBmpBuf.PixelFormat := pf24bit; // for QuickDrawShade()
  FBackGraph  := TBitmap.Create;
  FForeGraph  := TBitmap.Create;
  with Font do begin
    Color := clYellow;
    Name  := 'Times New Roman';
    Size  := 10;
    Style := [fsBold];
  end;
end;

destructor TSkyGuage.Destroy;
begin
  FBmpBuf.Free;
  FBackGraph.Free;
  FForeGraph.Free;
  inherited;
end;

procedure TSkyGuage.CMCtl3DChanged(var Message: TMessage);
begin
  inherited;
  if Visible then DoDrawFrame(Canvas, ClientRect);
end;

procedure TSkyGuage.DoDrawFrame(ACanvas: TCanvas; ARect: TRect);
begin
  if FDrawFrame then begin
    with ACanvas do begin
      if Self.Ctl3D then begin
        Pen.Color := clBtnShadow;
        MoveTo(ARect.Left, ARect.Bottom);
        LineTo(ARect.Left, ARect.Top);
        LineTo(ARect.Right -1, ARect.Top);
        Pen.Color := clBtnHighlight;
        LineTo(ARect.Right -1, ARect.Bottom -1);
        LineTo(ARect.Left, ARect.Bottom -1);
      end else begin
        Brush.Color := FrameColor;
        FrameRect(ARect);
      end;
    end;
  end;
end;

procedure TSkyGuage.Paint;

  function GetGradualColor(ACanvas: TCanvas; aRGB, gRGB: Longint; iValue, iWidth: Integer): TColor;
  var
    r, g, b, gr, gg, gb: Byte;
  begin
    r := GetRValue(aRGB);
    g := GetGValue(aRGB);
    b := GetBValue(aRGB);
    gr:= GetRValue(gRGB);
    gg:= GetGValue(gRGB);
    gb:= GetBValue(gRGB);
    r := r + (gr - r) * iValue div iWidth;
    g := g + (gg - g) * iValue div iWidth;
    b := b + (gb - b) * iValue div iWidth;
    Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));
  end;

  procedure DrawShade(ACanvas: TCanvas; ARect: TRect);
  var
    i, iWidth, iLeft, iStart, iSpace: Integer;
    AColor, GColor: Longint;
  begin
    iWidth := ARect.Right - ARect.Left;
    if iWidth <= 0 then Exit;
    AColor := ColorToRGB(ForeColor);  //应该转换一下，否则就不能正确处理clMenu之类颜色（全成黑色了）
    GColor := ColorToRGB(ShadeColor); //应该转换一下，否则就不能正确处理clMenu之类颜色（全成黑色了）
    iLeft  := ARect.Left;
    iSpace := 0;
    Inc(iSpace, Integer(FDrawFrame));
    Inc(iSpace, Integer(FKeepSpace));
    if iLeft < iSpace then iStart := iSpace - iLeft else iStart := 0;
    for i := iStart to iWidth -1 do begin
      ACanvas.Brush.Color := GetGradualColor(ACanvas, AColor, GColor, iWidth -i, iWidth);
      ACanvas.FillRect(Rect(iLeft + i, ARect.Top, iLeft + i +1, ARect.Bottom));
    end;
  end;

  procedure QuickDrawShade(Bmp: TBitmap; ARect: TRect);
  var
    r, g, b, gr, gg, gb: Byte;
    x, y, iWidth, iValue, iLeft, aRGB, gRGB, iSpace: Integer;
    p: PByte;
  begin
    aRGB := ColorToRGB(ForeColor);   //应该转换一下，否则就不能正确处理clMenu之类颜色（全成黑色了）
    gRGB := ColorToRGB(ShadeColor);  //应该转换一下，否则就不能正确处理clMenu之类颜色（全成黑色了）
    r := GetRValue(aRGB);
    g := GetGValue(aRGB);
    b := GetBValue(aRGB);
    gr:= GetRValue(gRGB);