• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 568
  • Last Modified:

"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?
0
rfwoolf
Asked:
rfwoolf
  • 8
  • 3
2 Solutions
 
Geert GruwezOracle 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 GruwezOracle 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 GruwezOracle 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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
Geert GruwezOracle 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 GruwezOracle 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 GruwezOracle 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 GruwezOracle 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 GruwezOracle 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

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 8
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now