"Progress Bar" form that can be called often throughout an application

I'd like a 'progress bar' that pops up in my application that offers some visual feedback to the user.
For example if I know a process has 5 steps, I can do something like this:

DoProgressBar(5 steps);

ProgressBarStatusMessage('Initiating connection to server...');

Then after each step:
IncrementProgressBar(1);
ProgressBarStatusMessage('Authenticating user');

...

IncrementProgressBar(1);
ProgressBarStatusMessage('Fetching products...');

...

IncrementProgressBar(1);
ProgressBarStatusMessage('Checking balances...');

etc

Perhaps somebody already has a unit and form that can do this?
LVL 13
rfwoolfAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Geert GOracle dbaCommented:
lol, i have a unit ...
i can display it's own progressbar or the one passed to the procedure.
now where did i put it ?
0
Geert GOracle dbaCommented:
it's actually a splash form with that functionality


unit SplashScreenForm;

interface

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

type
  TFrmSplashScreen = class(TForm)
    Panel1: TPanel;
    ProcessLabel: TLabel;
    Label1: TLabel;
    ProgressBarSplash: TProgressBar;
    pnlDecor: TPanel;
    Image1: TImage;
  private
    procedure MakeVisible;
    procedure Start(const maxVal,stepVal:integer); overload;
    procedure Start(const maxVal,stepVal:integer; const ProcessLabelText:string); overload;
    procedure Increment(n: integer = 1); overload;
    procedure Increment(ProcessLabelText: string; n: integer = 1); overload;
    procedure SetProcessLabel(const ProcessMessage: string);
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  FrmSplashScreen : TFrmSplashScreen = nil;

procedure SplashStart(const MaxVal, StepVal: integer); overload;
procedure SplashStart(const MaxVal, StepVal: Integer; ProcessLabelText: string); overload;
procedure SplashIncrement(n: integer = 1); overload;
procedure SplashIncrement(ProcessLabelText: string; n: integer = 1); overload;
procedure SplashSetProcessLabel(const ProcessMessage: string);
procedure SplashStop;

implementation

uses Variants;

{$R *.DFM}

procedure TFrmSplashScreen.Increment(n: integer = 1);
begin
  ProgressBarSplash.StepBy(n);
  ProgressBarSplash.Update;
  MakeVisible;
end;

procedure TFrmSplashScreen.Start(const maxVal, stepVal: integer);
begin
  with ProgressBarSplash do
  begin
    Min := 0;
    Max := maxVal;
    Step := stepVal;
  end;
  MakeVisible;
end;

procedure TFrmSplashScreen.SetProcessLabel(const ProcessMessage: string);
begin
  ProcessLabel.Caption := ProcessMessage;
  MakeVisible;
end;

procedure TFrmSplashScreen.Start(const maxVal, stepVal: integer;
  const ProcessLabelText: string);
begin
  Start(MaxVal, StepVal);
  SetProcessLabel(ProcessLabelText);
end;

procedure TFrmSplashScreen.Increment(ProcessLabelText: string; n: integer);
begin
  ProgressBarSplash.StepBy(n);
  SetProcessLabel(ProcessLabelText);
end;

constructor TFrmSplashScreen.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Increment;
end;

function SplashInit(Create: Boolean = True): Boolean;
begin
  if (FrmSplashScreen = nil) and Create then
  begin
    FrmSplashScreen := TFrmSplashScreen.Create(Application);
    FrmSplashScreen.Show;
    FrmSplashScreen.Update;
  end;
  Result := FrmSplashScreen <> nil;
end;

procedure SplashStart(const MaxVal, StepVal: integer);
begin
  if SplashInit then
    FrmSplashScreen.Start(MaxVal, StepVal);
end;

procedure SplashStart(const MaxVal, StepVal: Integer; ProcessLabelText: string);
begin
  if SplashInit then
    FrmSplashScreen.Start(MaxVal, StepVal, ProcessLabelText);
end;

procedure SplashIncrement(n: integer = 1);
begin
  if SplashInit then
    FrmSplashScreen.Increment(n);
end;

procedure SplashIncrement(ProcessLabelText: string; n: integer = 1);
begin
  if SplashInit then
    FrmSplashScreen.Increment(ProcessLabelText, n);
end;

procedure SplashSetProcessLabel(const ProcessMessage: string);
begin
  if SplashInit then
    FrmSplashScreen.SetProcessLabel(ProcessMessage);
end;

procedure SplashKill;
begin
  if SplashInit(False) then
    FreeAndNil(FrmSplashScreen);
end;

procedure SplashStop;
begin
  SplashKill;
end;

procedure TFrmSplashScreen.MakeVisible;
begin
  Invalidate;
  BringToFront;
  Refresh;
  Update;
end;

initialization
  SplashInit;
finalization
  if SplashInit(False) then SplashStop;
end.

Open in new window

0
Geert GOracle dbaCommented:
and dfm


object FrmSplashScreen: TFrmSplashScreen
  Left = 391
  Top = 366
  BorderIcons = []
  BorderStyle = bsNone
  ClientHeight = 163
  ClientWidth = 406
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 406
    Height = 163
    Align = alClient
    BevelWidth = 2
    BorderWidth = 1
    TabOrder = 0
    object ProcessLabel: TLabel
      Left = 78
      Top = 111
      Width = 85
      Height = 16
      HelpType = htKeyword
      Caption = 'Even geduld ...'
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -13
      Font.Name = 'Tahoma'
      Font.Style = [fsItalic]
      ParentFont = False
    end
    object Label1: TLabel
      Left = 78
      Top = 87
      Width = 249
      Height = 23
      HelpType = htKeyword
      Caption = 'Programma aan het laden, ...'
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -19
      Font.Name = 'Tahoma'
      Font.Style = []
      ParentFont = False
    end
    object ProgressBarSplash: TProgressBar
      Left = 78
      Top = 134
      Width = 241
      Height = 22
      TabOrder = 0
    end
    object pnlDecor: TPanel
      Left = 16
      Top = 12
      Width = 374
      Height = 68
      BevelOuter = bvNone
      Color = clWhite
      TabOrder = 1
      object Image1: TImage
        Left = -1
        Top = -3
        Width = 194
        Height = 67
        Center = True
      end
    end
  end
end

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

Geert GOracle dbaCommented:
you could change the procedure names easily to fit your procedure names

increment and set name is a one step procedure:
SplashIncrement('Authenticating user');
0
Geert GOracle dbaCommented:
found a secondary one for loading data:

it's with devexpress components
unit frmWaitScreen;

interface

uses
  Windows, Forms, Translator, Classes, Controls, ExtCtrls, StdCtrls, Messages,
  cxControls, cxContainer, cxEdit, cxProgressBar, ImgList, Graphics;

type
  TfrmWait = class(TForm)
    pbWait: TcxProgressBar;
    pnl: TPanel;
    lblTop: TLabel;
    lblMessage: TLabel;
    lblMiddle: TLabel;
    lblStepMessage: TLabel;
    procedure FormShow(Sender: TObject);
  private
    fStartTime: TDateTime;
    procedure WMHitCaption(var Msg: TMessage); message WM_NCHITTEST;
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  frmWait: TfrmWait;

procedure DataWait(Step: Integer = 0; StepType: Integer = 0; StepMessage: string = '');
procedure EndDataWait;

implementation

uses SysUtils;

{$R *.DFM}

constructor TfrmWait.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fStartTime := Now;
end;

procedure TfrmWait.FormShow(Sender: TObject);
begin
  fStartTime := Now;
  pbWait.Visible := False;
end;

// Steptype: 0 = not visible, 1 = step, 2 = max
procedure DataWait(Step: Integer = 0; StepType: Integer = 0; StepMessage: string = '');
begin
  Screen.Cursor := crHourglass;
  if not Assigned(frmWait) then
    frmWait := TfrmWait.Create(Application);
  if Assigned(frmWait) then
    with frmWait do
    begin
      lblStepMessage.Caption := StepMessage;
      if Visible and not pbWait.Visible and (Now - fStartTime > 2 / 24 / 60 / 60) then // 2 sec then
        pbWait.Visible := True;
      case StepType of
        1:
        begin
          if pbWait.Position + Step < pbWait.Properties.Max then
            pbWait.Position := pbWait.Position + Step
          else
            pbWait.Position := pbWait.Properties.Max;
        end;
        2:
        begin
          pbWait.Position := 0;
          pbWait.Properties.Max := Step;
        end;
      end;
      Show;
      Update;
      pbWait.Update;
      Update;
    end;
end;

procedure EndDataWait;
begin
  if Assigned(frmWait) then
    frmWait.Hide;
  Screen.Cursor := crDefault;
end;

procedure TfrmWait.WMHitCaption(var Msg: TMessage);
begin
  Msg.Result := HTCAPTION;
end;

end.

Open in new window

0
Geert GOracle dbaCommented:
dfm

forgive me for not translating the dutch words ... :)
object frmWait: TfrmWait
  Left = 396
  Top = 387
  Cursor = crHourGlass
  BorderStyle = bsNone
  Caption = 'Even geduld ...'
  ClientHeight = 129
  ClientWidth = 337
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poMainFormCenter
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 16
  object pbWait: TcxProgressBar
    Left = 0
    Top = 105
    Align = alBottom
    Properties.BeginColor = 11522520
    Style.BorderStyle = ebsNone
    Style.TextStyle = [fsBold]
    TabOrder = 0
    Width = 337
  end
  object pnl: TPanel
    Left = 0
    Top = 0
    Width = 337
    Height = 105
    Align = alClient
    BevelInner = bvLowered
    TabOrder = 1
    object lblTop: TLabel
      Left = 2
      Top = 2
      Width = 333
      Height = 16
      Align = alTop
      Alignment = taCenter
      ExplicitWidth = 4
    end
    object lblMessage: TLabel
      Left = 2
      Top = 18
      Width = 333
      Height = 33
      Align = alTop
      Alignment = taCenter
      Caption = 'Even geduld ...'
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -27
      Font.Name = 'Tahoma'
      Font.Style = []
      ParentFont = False
      ExplicitWidth = 177
    end
    object lblMiddle: TLabel
      Left = 2
      Top = 51
      Width = 333
      Height = 16
      Align = alTop
      Alignment = taCenter
      ExplicitWidth = 4
    end
    object lblStepMessage: TLabel
      Left = 2
      Top = 67
      Width = 333
      Height = 25
      Align = alTop
      Alignment = taCenter
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -21
      Font.Name = 'Tahoma'
      Font.Style = []
      ParentFont = False
      ExplicitWidth = 7
    end
  end
end

Open in new window

0
rfwoolfAuthor Commented:
Geert

Thanks but I'm a bit confused - none of the methods in the splash screen can be called, I why have you overloaded all these methods?
0
Geert GOracle dbaCommented:
overload ?
for backward compatibility for my projects


how do you mean, they can't be called ?

0
rfwoolfAuthor Commented:
Arrghh I was being an idiot...
I was trying to call a method of the form instead of a method of the unit.
Thanks :)
0
Geert GOracle dbaCommented:
ungh ... your welcome ...
i dunno about the idiot part ... don't know you that well ... but if you insist, ok ... :)
0
rfwoolfAuthor Commented:
Once I removed the intitialization and finilization section to make it no longer a Splash form, then it's perfect :)

Thank-you!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Delphi

From novice to tech pro — start learning today.