Measure/Forms/mProgressProFrm.pas

{*******************************************************************************
    单元名称： mProgressProFrm.pas

    单元说明： 任务清单效果的进度条。

    作者时间： Chenshilong, 2015-12-07
*******************************************************************************}


unit mProgressProFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, ExtCtrls, Gauges, jpeg;

type
  TProgressProForm = class(TForm)
    Shape1: TShape;
    Gauge1: TGauge;
    lblTitle: TLabel;
    lblPercent: TLabel;
    lblHint1: TLabel;
    lblHint2: TLabel;
    lblHint3: TLabel;
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TProgressPosType = (pptNo, pptAdd, pptSet);    // 进度不变；增加进度；指定进度；
  TProgressMemoType = (pmtNo, pmtAdd, pmtEdit);  // 备注信息不变；增加一条备注；修改当前这条备注。

procedure ProgressProCreate(AMaxValue: Integer = 100; ATitle: string = '正在处理请稍候>>>');
procedure ProgressProFree;
procedure ProgressProRun(AText: string; APos: Integer = 10;
                         ATextType: TProgressMemoType = pmtAdd; APosType: TProgressPosType = pptAdd);
procedure ProgressProTitle(ATitle: string);
function ProgressProHandle: THandle;
procedure ProgressProHide;     // 进度窗太大，会挡住其它提示条，所以隐藏先。

var
  ProgressProForm: TProgressProForm = nil;

const
  sc_DragMove = $f012;

implementation

uses ScUtils;

{$R *.dfm}

procedure ProgressProCreate(AMaxValue: Integer; ATitle: string);
begin
  if ProgressProForm = nil then
    ProgressProForm := TProgressProForm.Create(nil);
  ProgressProForm.lblTitle.Caption := ATitle;
  ProgressProForm.Gauge1.MaxValue := AMaxValue;
  ProgressProForm.Gauge1.Progress := 0;
  ProgressProForm.Show;
  ProgressProForm.Update;
end;

procedure ProgressProFree;
begin
  if ProgressProForm <> nil then
  begin
    if not ProgressProForm.Visible then
    begin
      ProgressProForm.Visible := True;
      ProgressProForm.Update;
    end;

       
    with ProgressProForm.Gauge1 do
    begin
      if (Progress <> MaxValue) then
      ProgressProRun('已完成。', MaxValue, pmtAdd, pptSet);
    end;

    // 关闭前要延迟500ms，有些地方如果不延迟，关得太快，感觉进度条没走完就关了，体验很不好。
    Sleep(500);

    FreeAndNil(ProgressProForm);
  end;
end;

procedure ProgressProRun(AText: string; APos: Integer;
                         ATextType: TProgressMemoType; APosType: TProgressPosType);
begin
  if ProgressProForm = nil then Exit;
  with ProgressProForm do
  begin
    if APosType = pptAdd then
      Gauge1.Progress := Gauge1.Progress + APos
    else if APosType = pptSet then
      Gauge1.Progress := APos;

    if Gauge1.Progress > Gauge1.MaxValue then     // 如果算得不对，缩回5格
      Gauge1.Progress := Gauge1.MaxValue - 2;

    lblPercent.Caption := IntToStr(Gauge1.PercentDone) + '%';

    if (ATextType <> pmtNo) or (AText <> '') then
    begin
      if ATextType = pmtAdd then
      begin
        if lblHint1.Caption = '' then
        begin
          lblHint1.Caption := AText;
          lblHint1.Update;
        end
        else if lblHint2.Caption = '' then
        begin
          lblHint2.Caption := AText;
          lblHint2.Update;
        end
        else if lblHint3.Caption = '' then
        begin
          lblHint3.Caption := AText;
          lblHint3.Update;
        end
        else
        begin
          lblHint1.Caption := lblHint2.Caption;
          lblHint2.Caption := lblHint3.Caption;
          lblHint3.Caption := AText;
          lblHint1.Update;
          lblHint2.Update;
          lblHint3.Update;
        end;
      end
      else if ATextType = pmtEdit then
      begin
        if (lblHint1.Caption = '') or (lblHint2.Caption = '') then
        begin
          lblHint1.Caption := AText;
          lblHint1.Update;
        end
        else if lblHint3.Caption = '' then
        begin
          lblHint2.Caption := AText;
          lblHint2.Update;
        end
        else
        begin
          lblHint3.Caption := AText;
          lblHint3.Update;
        end;
      end;

    end;

//    Update;
  end;
end;

procedure ProgressProTitle(ATitle: string);
begin
  if ProgressProForm = nil then Exit;
  with ProgressProForm do
  begin
    lblTitle.Caption := ATitle;
    lblTitle.Update;
  end;
end;

function ProgressProHandle: THandle;
begin
  Result := 0;
  if ProgressProForm <> nil then
    Result := ProgressProForm.Handle;
end;

procedure TProgressProForm.Shape1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  ReleaseCapture;
  (ProgressProForm as TWinControl).PerForm(wm_SysCommand, sc_DragMove, 0);
end;

procedure ProgressProHide;
begin
  if ProgressProForm <> nil then
    ProgressProForm.Hide;
end;

end.