Mostrar Form com o Progresso da Execução de um Loop (For/Do)

unit UnitProgresso;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.ComCtrls;

type
  TFormProgresso = class(TForm)
    PanelGauge: TPanel;
    PanelMsg: TPanel;
    PanelCancelar: TPanel;
    ButtonCancelar: TButton;
    ProgressBar1: TProgressBar;
    procedure FormCreate(Sender: TObject);
    procedure ButtonCancelarClick(Sender: TObject);
  private
    { Private declarations }
    FCancelou: boolean;
    FMensagem: string;
    FWindowList: Pointer;
    function GetValorAtual: integer;
    function GetValorMaximo: integer;
  public
    { Public declarations }
    procedure Exibe;
    procedure Incrementa(ValorIncrementar: integer = 1; Mensagem: string = '');
    property Cancelou: boolean read FCancelou;
    property ValorAtual: integer read GetValorAtual;
    property ValorMaximo: integer read GetValorMaximo;
    property WindowList: Pointer read FWindowList;
  end;

function CriaProgresso(Caption, Mensagem: string; ValorMaximo: integer; BotaoCancelar: boolean = True): TFormProgresso;
procedure DestroiProgresso(Progresso: TFormProgresso);

implementation

{$R *.dfm}

procedure TFormProgresso.ButtonCancelarClick(Sender: TObject);
begin
  FCancelou := Application.MessageBox('Deseja realmente cancelar o processo?','Cancelar',MB_YESNO) = mrYes;
end;

function CriaProgresso(Caption, Mensagem: string; ValorMaximo: integer;
 BotaoCancelar: boolean = True): TFormProgresso;
var
  FFormProgresso: TFormProgresso;
begin
  Application.CreateForm(TFormProgresso, FFormProgresso);
  if trim(Caption) > '' then
    FFormProgresso.Caption := Caption;
  FFormProgresso.PanelMsg.Caption := Mensagem;
  FFormProgresso.PanelMsg.Visible := (trim(Mensagem) > '');
  FFormProgresso.ProgressBar1.Max := ValorMaximo;
  FFormProgresso.PanelCancelar.Visible := BotaoCancelar;
  Result := FFormProgresso;
end;


procedure TFormProgresso.Exibe;
begin
  FWindowList := DisableTaskWindows(Self.Handle);
  Show;
end;

procedure DestroiProgresso(Progresso: TFormProgresso);
begin
  EnableTaskWindows(Progresso.WindowList);
  Progresso.Close;
  FreeAndNil(Progresso);
end;

procedure TFormProgresso.FormCreate(Sender: TObject);
begin
  PanelMsg.Caption := '';
  PanelGauge.Caption := '';
  PanelCancelar.Caption := '';
  FCancelou := False;
end;

function TFormProgresso.GetValorAtual: integer;
begin
  Result := ProgressBar1.Position;
end;

function TFormProgresso.GetValorMaximo: integer;
begin
  Result := ProgressBar1.Max;
end;

procedure TFormProgresso.Incrementa(ValorIncrementar: integer;
 Mensagem: string);
begin
  if trim(Mensagem) > '' then PanelMsg.Caption := Mensagem;
  ProgressBar1.StepBy(ValorIncrementar);
  ProgressBar1.Repaint;
end;

end.

object FormProgresso: TFormProgresso
  Left = 0
  Top = 0
  AutoSize = True
  BorderIcons = []
  BorderStyle = bsSizeToolWin
  Caption = 'FormProgresso'
  ClientHeight = 119
  ClientWidth = 549
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PanelGauge: TPanel
    Left = 0
    Top = 32
    Width = 549
    Height = 41
    BevelOuter = bvNone
    Caption = 'PanelGauge'
    TabOrder = 0
    object ProgressBar1: TProgressBar
      Left = 19
      Top = 8
      Width = 511
      Height = 17
      TabOrder = 0
    end
  end
  object PanelMsg: TPanel
    Left = 0
    Top = 0
    Width = 549
    Height = 40
    BevelOuter = bvNone
    Caption = 'PanelMsg'
    TabOrder = 1
  end
  object PanelCancelar: TPanel
    Left = 0
    Top = 79
    Width = 549
    Height = 40
    BevelOuter = bvNone
    Caption = 'PanelCancelar'
    TabOrder = 2
    object ButtonCancelar: TButton
      Left = 426
      Top = 7
      Width = 113
      Height = 25
      Caption = 'Cancelar'
      TabOrder = 0
      OnClick = ButtonCancelarClick
    end
  end
end

procedure TForm2.Button1Click(Sender: TObject);
var
  Progresso, Progresso2, Progresso3: TFormProgresso;
  i, i2, i3, maximo, maximo2, maximo3: integer;
begin
  maximo := 20;
  maximo2 := 12;
  maximo3 := 5;

  // cria a tela, permitindo o cancelamento do processo
  Progresso := CriaProgresso('Teste Progresso', 'Teste de exibicao de progresso', maximo);
  Progresso.Exibe;

  for i := 1 to maximo do
  begin
    Application.ProcessMessages;

    Progresso.Incrementa;
    Sleep(1000);

    // quando chegar a 10, inicia uma nova barra de progresso
    if Progresso.ValorAtual = 10 then
    begin
      // cria a tela, e NÃO permite o cancelamento do processo
      Progresso2 := CriaProgresso('Teste Progresso 2', 'Teste de exibicao da segunda barra de progresso', maximo2, False);
      Progresso2.Exibe;

      for i2 := 1 to maximo2 do
      begin
        Application.ProcessMessages;
        Progresso2.Incrementa;
        Sleep(1000);

        // quando o segundo loop chegar a 9, inicia uma nova barra
        // de progresso que altera a mensagem a cada incremento
        if Progresso2.ValorAtual = 9 then
        begin
          // cria a tela, e NÃO permite o cancelamento do processo
          Progresso3 := CriaProgresso('Teste Progresso 3', 'Teste de exibicao da terceira barra de progresso', maximo3, False);
          Progresso3.Exibe;

          for i3 := 1 to maximo3 do
          begin
            Application.ProcessMessages;
            Progresso3.Incrementa(1,'Iteração '+inttostr(i3)+' de '+inttostr(maximo2));
            Sleep(1000);
          end;

          DestroiProgresso(Progresso3);
        end;

      end;

      DestroiProgresso(Progresso2);
    end;

    if Progresso.Cancelou then
      break;
  end;

  if Progresso.Cancelou then
    ShowMessage('Usuário cancelou a execução')
  else
    ShowMessage('Processo finalizado com sucesso');

  DestroiProgresso(Progresso);
end;