开源控件大家做（3） 进度条

piaoxueboy

//==============================================================================
//                             TTYProgressBar
//
//           版本: v1.00   设计者：田逸    日期：20120430
//
// 功能说明:
//   进度条控件 (可以在lazarus for win 和lzazrus for linux(ubuntu) 下使用)
//
//
// 属性说明：
//   BackColor      进度条底色
//   ForeColor      进度度前景色
//   FixValue       触发值  取值范围 0-100
//   Kind           进度的种类，bkHorizontal：水平  bkVertical:垂直
//   TextMode       进度值显示形式
//   TextPosition   进度值在进度条中的位置
//   ShowText       是否显示进度值
//
// 事件说明：
//   OnFixValue     当进度值大于等于FixValue值时，将触发此事件
//
// 备注：
//
//==============================================================================
unit TYProgressBar;
{$mode objfpc}{$H+}
interface
uses
  LCLINtf, SysUtils, Classes, Graphics, Controls, StdCtrls, Types,
  ExtCtrls, LResources;
  
type
  TBarTextMode     = (tmPercent, tmCurrentPerMax);
  TBarTextPosition = (tpGaugeCenter, tpCenter);
  TBarKind         = (bkHorizontal, bkVertical);
  TBarShape        = (bsNone, bsBox, bsFrame);
  TBarStyle        = (btNone, btLowered, btRaised);
  { TYProgressBar }
  TTYProgressBar = class(TGraphicControl)
  private
    FBackColor: TColor;
    FBorderStyle: TBorderStyle;
    FCurValue: Longint;
    FFixValue: Longint;
    FForeColor: TColor;
    FKind: TBarKind;
    FMaxValue: Longint;
    FMinValue: Longint;
    FShape: TBarShape;
    FShowText: Boolean;
    FStyle: TBarStyle;
    FTextMode: TBarTextMode;
    FTextPosition: TBarTextPosition;
    FOnFixValue: TNotifyEvent;
    function GetPercentDone: Longint;
    procedure PaintAsBar(Bitmap: TBitmap; PaintRect: TRect);
    procedure PaintAsText(Bitmap: TBitmap; PaintRect: TRect);
    procedure PaintBackground(Bitmap: TBitmap);
    procedure SetBackColor(const Value: TColor);
    procedure SetBarKind(const Value: TBarKind);
    procedure SetBarShape(const Value: TBarShape);
    procedure SetBarStyle(const Value: TBarStyle);
    procedure SetBorderStyle(const Value: TBorderStyle);
    procedure SetFixValue(const Value: Longint);
    procedure SetForeColor(const Value: TColor);
    procedure SetMaxValue(const Value: Longint);
    procedure SetMinValue(const Value: Longint);
    procedure SetProgress(Value: Longint);
    procedure SetShowText(const Value: Boolean);
    procedure SetTextMode(const Value: TBarTextMode);
    procedure SetTextPosition(const Value: TBarTextPosition);
  protected
    procedure Paint; override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddProgress(const Value: Longint);
    property PercentDone: Longint read GetPercentDone;
  published
    property Align;
    property Anchors;
    property BorderSpacing;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property Kind: TBarKind read FKind write SetBarKind default bkHorizontal;
    property Shape: TBarShape read FShape write SetBarShape default bsNone;
    property Style: TBarStyle read FStyle write SetBarStyle default btNone;
    property FixValue: Longint read FFixValue write SetFixValue;
    property ShowText: Boolean read FShowText write SetShowText default True;
    property TextMode: TBarTextMode read FTextMode write SetTextMode ;
    property TextPosition: TBarTextPosition read FTextPosition write SetTextPosition default tpCenter;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property ForeColor: TColor read FForeColor write SetForeColor default clBlue;
    property BackColor: TColor read FBackColor write SetBackColor default clWhite;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
    property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
    property Progress: Longint read FCurValue write SetProgress;
    property OnFixValue: TNotifyEvent read FOnFixValue write FOnFixValue;
    property OnChangeBounds;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnPaint;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

type
  TBltBitmap = class(TBitmap)
    procedure MakeLike(ATemplate: TBitmap);
  end;

procedure TBltBitmap.MakeLike(ATemplate: TBitmap);
begin
  Width := ATemplate.Width;
  Height := ATemplate.Height;
  Canvas.Brush.Color := clWindowFrame;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(Rect(0, 0, Width, Height));
end;

procedure Register;
begin
  RegisterComponents('TianYi', [TTYProgressBar]);
end;  
      
      
function SolveForX(Y, Z: Longint): Longint;
begin
  Result:= Trunc( Z * (Y * 0.01) );
end;

function SolveForY(X, Z: Longint): Longint;
begin
  if Z = 0 then
    Result:= 0
  else
    Result:= Trunc( (X * 100.0) / Z );
end;

{ TTYProgressBar }
constructor TTYProgressBar.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width:= 200;
  Height:= 25;
  FMinValue:= 0;
  FMaxValue:= 100;
  FCurValue:= 0;
  FFixValue:= 0;
  FKind:= bkHorizontal;
  FShowText:= True;
  FTextMode:= tmPercent;
  FTextPosition:= tpCenter;
  FBorderStyle:= bsSingle;
  FForeColor:= clBlue;
  FBackColor:= clWhite;
end;
destructor TTYProgressBar.Destroy;
begin
  inherited Destroy;
end;

procedure TTYProgressBar.AddProgress(const Value: Longint);
begin
  Progress:= FCurValue + Value;
  Invalidate;
end;

function TTYProgressBar.GetPercentDone: Longint;
begin
  Result:= SolveForY(FCurValue - FMinValue, FMaxValue - FMinValue);
end;

procedure TTYProgressBar.PaintAsBar(Bitmap: TBitmap; PaintRect: TRect);
var
  FillSize: Longint;
  W, H: Integer;
begin
  W:= PaintRect.Right - PaintRect.Left + 1;
  H:= PaintRect.Bottom - PaintRect.Top + 1;
  Bitmap.Canvas.Brush.Color:= FBackColor;
  Bitmap.Canvas.FillRect(PaintRect);
  Bitmap.Canvas.Pen.Color:= FForeColor;
  Bitmap.Canvas.Pen.Width:= 1;
  Bitmap.Canvas.Brush.Color:= FForeColor;
  case FKind of
    bkHorizontal:
      begin
        FillSize := SolveForX(PercentDone, W);
        if FillSize > W then FillSize := W;
        if FillSize > 0 then Bitmap.Canvas.FillRect(Rect(PaintRect.Left, PaintRect.Top, FillSize, H));
      end;
    bkVertical:
      begin
        FillSize:= SolveForX(PercentDone, H);
        if FillSize > H then FillSize:= H;
        if FillSize > 0 then Bitmap.Canvas.FillRect(Rect(PaintRect.Left, H-FillSize+1,W, PaintRect.Bottom ));
      end;
  end;
end;

procedure TTYProgressBar.PaintAsText(Bitmap: TBitmap; PaintRect: TRect);
var
  S: string;
  X, Y: Integer;
  OverRect: TBltBitmap;
  procedure  IsHorizontal;
  begin
    if FTextPosition = tpGaugeCenter then
      begin
        if SolveForX(PercentDone, PaintRect.Right - PaintRect.Left + 1) < OverRect.Canvas.TextWidth(S) then S:= '';
        X := (SolveForX(PercentDone, PaintRect.Right - PaintRect.Left + 1) - PaintRect.Left + 1 - OverRect.Canvas.TextWidth(S)) div 2;
        Y := (PaintRect.Bottom - PaintRect.Top + 1 - OverRect.Canvas.TextHeight(S)) div 2;
      end
    else
      begin
        x:=(PaintRect.Right - PaintRect.Left + 1 - OverRect.Canvas.TextWidth(S)) div 2;
        Y:=(PaintRect.Bottom - PaintRect.Top + 1 - OverRect.Canvas.TextHeight(S)) div 2;
      end;
  end;
  procedure  IsVertical;
  var
    TempHeight: Integer;
  begin
    TempHeight:= PaintRect.Bottom - PaintRect.Top + 1;
    if FTextPosition = tpGaugeCenter then
      begin
        if SolveForX(PercentDone,TempHeight) < OverRect.Canvas.TextHeight(S) then S:= '';
        X:= (PaintRect.Right - PaintRect.Left + 1 - OverRect.Canvas.TextWidth(S)) div 2;
        y:= TempHeight-SolveForX(PercentDone,TempHeight) + ((SolveForX(PercentDone,TempHeight)  - OverRect.Canvas.TextHeight(S)) div 2);
      end
    else
      begin
        X:= (Width  - OverRect.Canvas.TextWidth(S))  div 2;
        Y:= (Height - OverRect.Canvas.TextHeight(S)) div 2;
      end;
  end;
begin
  OverRect:= TBltBitmap.Create;
  OverRect.Width:= Bitmap.Width;
  OverRect.Height:= Bitmap.Height;
  try
    OverRect.MakeLike(Bitmap);
    PaintBackground(OverRect);
    if FTextMode=tmPercent then
      S:= Format('%d%%', [PercentDone])
    else
      S:= Format('%d/%d', [FCurValue ,FMaxValue]);
    case FKind of
      bkHorizontal: IsHorizontal;
       bkVertical : IsVertical ;
    end;
    with OverRect.Canvas do
      begin
        OverRect.Canvas.Brush.Style:= bsClear;
        OverRect.Canvas.Font:= Self.Font;
        OverRect.Canvas.Font.Color:= clWhite;
        OverRect.Canvas.TextRect(PaintRect, X, Y, S);
      end;
    //AnImage.Canvas.CopyMode:= cmSrcInvert;
    //AnImage.Canvas.Draw(0, 0, OverRect);
    Bitmap.Canvas.CopyMode:= cmSrcInvert;
    Bitmap.Canvas.CopyRect(PaintRect, OverRect.Canvas, PaintRect);
  finally
    OverRect.Free;
  end;
end;

procedure TTYProgressBar.PaintBackground(Bitmap: TBitmap);
var
  ARect: TRect;
begin
  Bitmap.Canvas.CopyMode:= cmBlackness;
  ARect:= Rect(0, 0, Bitmap.Width, Bitmap.Height);
  Bitmap.Canvas.CopyRect(ARect, Bitmap.Canvas, ARect);
  Bitmap.Canvas.CopyMode:= cmSrcCopy;
end;

procedure TTYProgressBar.SetBackColor(const Value: TColor);
begin
  if Value = FBackColor then Exit;
  FBackColor:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetBarKind(const Value: TBarKind);
begin
  if Value = FKind then Exit;
  FKind:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetBarShape(const Value: TBarShape);
begin
  if Value = FShape then Exit;
  FShape:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetBarStyle(const Value: TBarStyle);
begin
  if Value = FStyle then Exit;
  FStyle:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetBorderStyle(const Value: TBorderStyle);
begin
  if Value = FBorderStyle then Exit;
  FBorderStyle := Value;
  Invalidate;
end;

procedure TTYProgressBar.SetFixValue(const Value: Longint);
begin
  if (Value = FFixValue) then Exit;
  if (Value in [0..100]) then
    FFixValue:= Value
  else
    raise EInvalidOperation.CreateFmt('Value must be between %d and %d', [0, 100]);
end;

procedure TTYProgressBar.SetForeColor(const Value: TColor);
begin
  if Value = FForeColor then Exit;
  FForeColor:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetMaxValue(const Value: Longint);
begin
  if Value = FMaxValue then Exit;
  if Value < FMinValue then
    if not (csLoading in ComponentState) then
      raise EInvalidOperation.CreateFmt('Value must be between %d and %d', [FMinValue + 1, MaxInt]);
  FMaxValue:= Value;
  if FCurValue > Value then FCurValue:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetMinValue(const Value: Longint);
begin
  if Value = FMinValue then Exit;
  if Value > FMaxValue then
    if not (csLoading in ComponentState) then
      raise EInvalidOperation.CreateFmt('Value must be between %d and %d', [-MaxInt, FMaxValue - 1]);
  FMinValue:= Value;
  if FCurValue < Value then FCurValue:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetProgress(Value: Longint);
var
  TempPercent: Longint;
begin
  if FCurValue = Value then Exit;
  if Value < FMinValue then
    Value:= FMinValue
  else if Value > FMaxValue then
    Value:= FMaxValue;
  TempPercent:= GetPercentDone;
  FCurValue:= Value;
  if (TempPercent <> GetPercentDone) or (FTextMode = tmCurrentPerMax) then
    Invalidate;
  if (GetPercentDone >= FFixValue) and (Assigned(OnFixValue)) then FOnFixValue(self);
end;

procedure TTYProgressBar.SetShowText(const Value: Boolean);
begin
  if Value = FShowText then  Exit;
  FShowText:= Value;
  Invalidate;
end;

procedure TTYProgressBar.SetTextMode(const Value: TBarTextMode);
begin
  if Value = FTextMode then Exit;
  FTextMode:= Value;
  Invalidate;
end;
procedure TTYProgressBar.SetTextPosition(const Value: TBarTextPosition);
begin
  if Value = FTextPosition then Exit;
  FTextPosition:= Value;
  Invalidate;
end;

procedure TTYProgressBar.Paint;
var
  TheImage: TBitmap;
  OverlayImage: TBltBitmap;
  PaintRect: TRect;
  Color1, Color2: TColor;
  Temp: TColor;
  LeftOffset, TopOffset,
  WidthOffset, HeightOffset: Integer;
  procedure BevelRect(const R: TRect);
  begin
    //with Canvas do
      begin
        Canvas.Pen.Color:= Color1;
        Canvas.PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top), Point(R.Right, R.Top)]);
        Canvas.Pen.Color:= Color2;
        Canvas.PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom), Point(R.Left, R.Bottom)]);
      end;
  end;
begin
  case FStyle of
    btLowered:
      begin
        Color1:= clBtnShadow;
        Color2:= clBtnHighlight;
      end;
    btRaised:
      begin
        Color1:= clBtnHighlight;
        Color2:= clBtnShadow;
      end;
    btNone:
      begin
        //WidthOffset  :=0;
        //HeightOffset :=0;
      end;
  end;
  case FShape of
    bsNone:
      begin
        LeftOffset:= 0;      WidthOffset := 0;
        TopOffset := 0;      HeightOffset:= 0;
      end;
    bsBox:
      begin
        BevelRect(Rect(0, 0, Width - 1, Height - 1));
        LeftOffset:= 2;     WidthOffset := 5;
        TopOffset := 2;     HeightOffset:= 5;
      end;
    bsFrame:
      begin
        Temp:= Color1;
        Color1:= Color2;
        BevelRect(Rect(1, 1, Width - 1, Height - 1));
        Color2:= Temp;
        Color1:= Temp;
        BevelRect(Rect(0, 0, Width - 2, Height - 2));
        LeftOffset:=2;     WidthOffset  :=5;
        TopOffset :=2;     HeightOffset :=5;
      end;
  end;
  TheImage:= TBitmap.Create;
  try
    TheImage.Height:= Height - HeightOffset;
    TheImage.Width := Width  - WidthOffset;
    PaintBackground(TheImage);
    PaintRect:= Rect(0, 0, Width, Height);
    if FBorderStyle = bsSingle then InflateRect(PaintRect, -1, -1);
    OverlayImage := TBltBitmap.Create;
    OverlayImage.Height:= TheImage.Height;
    OverlayImage.Width:= TheImage.Width;
    try
      OverlayImage.MakeLike(TheImage);
      PaintBackground(OverlayImage);
      PaintAsBar(OverlayImage, PaintRect);
      TheImage.Canvas.CopyMode:= cmSrcInvert;
      TheImage.Canvas.Draw(0, 0, OverlayImage);
      TheImage.Canvas.CopyMode:= cmSrcCopy;
      if ShowText then PaintAsText(TheImage, PaintRect);
    finally
      OverlayImage.Free;
    end;
    Canvas.CopyMode:= cmSrcCopy;
    Canvas.Draw(LeftOffset, TopOffset, TheImage);
  finally
    TheImage.Destroy;
  end;
  //inherited Paint;
end;

initialization
{$I typrogressbar.lrs}
end.

piaoxueboy

逍遥派掌门人

很不错！

你们的辛勤劳动浇灌Lazarus这朵小花，同时给社区带来活力！

感谢你们！

ft3058

问什么我运行时出现调试器错误呢，谁能给个答案啊谢谢

ft3058

且这一行报错Application.CreateForm(TForm1, Form1);

逍遥派掌门人

这个问题和控件无关啊，看有没有别的问题。