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;
    mmTask: TMemo;
    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(AMemoValue: string; APosValue: Integer = 10;
                         AMemoType: TProgressMemoType = pmtAdd; APosType: TProgressPosType = pptAdd);
procedure ProgressProTitle(ATitle: string);
function ProgressProHandle: THandle;

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

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

    FreeAndNil(ProgressProForm);
  end;
end;

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

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

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

    if (AMemoType <> pmtNo) or (AMemoValue <> '') then
    begin
      with mmTask.Lines do
      begin
        if (AMemoType = pmtEdit) and (Count > 0) then
          Delete(Count - 1);
        Add(AMemoValue);
      end;
    end;

    Update;
  end;
end;

procedure ProgressProTitle(ATitle: string);
begin
  if ProgressProForm = nil then Exit;
  with ProgressProForm do
  begin
    lblTitle.Caption := ATitle;
    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;

end.