[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

How to implement a progressbar into this code?

Posted on 2009-02-15
16
Medium Priority
?
507 Views
Last Modified: 2012-05-06
Hi folks, I have this code which searches files for a string replace. I would like it to show progress by means of a progressbar. Does anyone know how to implement that, I'm not sure in which procedure it should be done as well as how it should be done.

Regards Peter
procedure TForm1.Replace_Text(FName, OldText, NewText: string);
var
  B:      Boolean;
  I:      Integer;
  L:      Integer;
  P:      Integer;
  StrList:TStringList;
  S:      string;
  T:      string;
  R:      string;
begin
  StrList := TStringList.Create;
  B := False;
  try
    L := Length(OldText);
    if Load_From_File(FName, StrList) then
    for I := 0 to StrList.Count-1 do
    begin
      S := StrList.Strings[I];
      P := Pos(OldText, S);
      if (P>0) then
      begin
        T := Copy(S, 1, P-1);
        R := Copy(S, P+L, Length(S)-P-L+1);
        S := T + NewText + R;
        StrList.Strings[I] := S;
        B := True;
      end;
    end;
  finally
    if B then
    begin
      StrList.SaveToFile(FName);
      ListBox1.Items.Add(FName);
      Application.ProcessMessages;
    end;
    StrList.Destroy;
  end;
end;
 
procedure TForm1.Replace_File(PathName: string; SL: TStringList);
var
  Found:         Integer;
  Attr:          Integer;
  I:             Integer;
//  P:             Integer;
  S:             string;
  T:             string;
  FName:         string;
  DirName:       string;
  SearchRec:     TSearchRec;
  procedure Prepare_For_Replace(Name: string);
  begin
    if ((FileGetAttr(Name) and faReadOnly) > 0) then
      FileSetAttr(Name, FileGetAttr(Name) xor faReadOnly);
    if ((FileGetAttr(Name) and faHidden) > 0) then
      FileSetAttr(Name, FileGetAttr(Name) xor faHidden);
    if ((FileGetAttr(Name) and faSysFile) > 0) then
      FileSetAttr(Name, FileGetAttr(Name) xor faSysFile);
  end;
begin
  Attr := faDirectory;
  Found := FindFirst(PathName+'*.*', Attr, SearchRec);
  while (Found=0) do
  try
    if (((FileGetAttr(SearchRec.Name) and faArchive) > 0)
    or  ((FileGetAttr(SearchRec.Name) and faAnyFile) > 0)) then
    for I := 0 to SL.Count-1 do
    begin
      FName := PathName + SearchRec.Name; // SL.Strings[I];
      if FileExists(FName) then
      begin
        Prepare_For_Replace(FName);
        S := UpperCase(ExtractFileExt(FName));
        T := UpperCase(SL.Strings[I]);
        {
        P := Pos('.', T);
        Delete(T, 1, P-1);
        }
        T := UpperCase(ExtractFileExt(T));
        if (S=T) then
        begin
          Prepare_For_Replace(FName);
          // Here to be a replacement
          if (edit1.Text<>'') then
            Replace_Text(FName, edit1.Text, Edit2.Text);
        end;
      end;
    end;
    if ((SearchRec.Attr=2064) or (SearchRec.Attr=16))
    and (not (SearchRec.Name[1]='.')) then
    begin
      DirName := PathName + SearchRec.Name + '\';
      Replace_File(DirName, SL);
    end;
  finally
    Found := FindNext(SearchRec);
  end;
  FindClose(SearchRec);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  C:             Char;
  I:             Integer;
  PCRootPathName:PChar;
  DriveType:     DWORD;
  S:             string;
  SL:            TStringList;
begin
  ListBox1.Clear;
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  SL := TStringList.Create;
  try
    for I := 0 to CheckListBox1.Items.Count-1 do  // add extensions to search for
      if (CheckListBox1.Checked[I]) then
        SL.Add(CheckListBox1.Items.Strings[I]);
        // To scan all harddisks uncomment following code and replace
        // Replace_File('c:\bck\', SL) with Replace_File(S, SL);
 
   // for C := 'A' to 'C' do
   // begin
     // S := C + ':\';
     // PCRootPathName := PChar(S);
     // DriveType := GetDriveType(PCRootPathName);
     // if (DriveType=DRIVE_FIXED) then  // DRIVE_FIXED is HDD
      begin
       // ListBox1.Items.Add('Current scanned HDD is ' + S);
        Application.ProcessMessages;
        Replace_File(AddTrailingBackslash(btn1.text), SL); // Replace_File(S, SL);
      end;
   // end;
  finally
    Screen.Cursor := crDefault;
    SL.Destroy;
    ListBox1.Items.Add('Done.');
    ListBox1.Items.Add('Replaced '+ edit1.Text+' in '+ inttostr(listbox1.items.count -1)+' files');
  end;
end;

Open in new window

0
Comment
Question by:PeterdeB
  • 6
  • 6
  • 3
  • +1
16 Comments
 
LVL 38

Expert Comment

by:Geert Gruwez
ID: 23646476
it looks like you have a list of extensions for files in CheckListBox1
you want to change the text from Edit1 into Edit2 in the files with these extensions

if you want a progressbar, you will need to change some stuff
first consider putting this replace text routine into a thread
next let the the thread find all the files matching the criteria and put them in a list (stringlist)
(you will have a count of matching files then = max progressbar)
next process the files, 1 by 1, and thus updating the progressbar per file processed

need any help with threads ?
this is a sample using a thread and progressbar :
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_23848904.html

need any more help converting ?
0
 
LVL 19

Expert Comment

by:MerijnB
ID: 23647605
The problem with proper progress information is that you need to know up front how much work you have to do. In this you don't really know that, unless you first do a run to find all files you need to replace, and then doing the actual replacing. This will take some more time though, so you'll first have to choose if you think it's worth that.
0
 
LVL 38

Expert Comment

by:Geert Gruwez
ID: 23648430
i modified the code (not a little) and got to this:


unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CheckLst;
 
type
  TForm1 = class(TForm)
    CheckListBox1: TCheckListBox;
    btn1: TEdit;
    Edit1: TEdit;
    Edit2: TEdit;
    ListBox1: TListBox;
  private
    fFileChanged: boolean;
    procedure Button1Click(Sender: TObject);
    procedure Replace_Text(FName, OldText, NewText: string);
    procedure StrListChanged(Sender: TObject);
    procedure ProcessMatchingFiles(FindText, ReplaceText: string; FileList: TStrings);
    procedure FindMatchingFiles(PathName: string; Extensions, FileList: TStrings);
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.StrListChanged(Sender: TObject);
begin
  fFileChanged := True;
end;
 
procedure TForm1.Replace_Text(FName, OldText, NewText: string);
var StrList:TStringList;
begin
  StrList := TStringList.Create;
  try
    StrList.LoadFromFile(fName);
    StrList.OnChange := StrListChanged;
    fFileChanged := False;
    StrList.Text := StringReplace(StrList.Text, OldText, NewText, [rfReplaceAll]);
    if fFileChanged then
      StrList.SaveToFile(fName);
  finally
    FreeAndNil(StrList);
  end;
end;
 
procedure TForm1.ProcessMatchingFiles(FindText, ReplaceText: string; FileList: TStrings);
var I: Integer;
begin
  //Progressbar.Max := FileList.Count;
  //Progressbar.Position := 0;
  for I := 0 to FileList.Count-1 do
  begin
    Replace_Text(FileList[I], FindText, ReplaceText);
    //Progressbar.Step(1);
  end;
end;
 
procedure TForm1.FindMatchingFiles(PathName: string; Extensions, FileList: TStrings);
var
  SearchRec:     TSearchRec;
 
  procedure CheckFile(aFileName: string);
  var I: Integer;
  begin
    if (aFileName[1] <> '.') then
    begin
      if SearchRec.Attr and faDirectory <> 0 then
        FindMatchingFiles(IncludeTrailingPathDelimiter(aFileName), Extensions, FileList)
      else
      begin
        if SearchRec.Attr and faArchive <> 0 then
          for I := 0 to Extensions.Count-1  do
            if SameText(ExtractFileExt(aFileName), Extensions[I]) then
            begin
              FileList.Add(aFileName);
              Break;
            end;
      end;
    end;
  end;
 
begin
  if FindFirst(PathName+'*.*', faAnyFile, SearchRec) = 0 then
  try
    CheckFile(PathName + SearchRec.Name);
    while FindNext(SearchRec) = 0 do
      CheckFile(PathName + SearchRec.Name);
  finally
    FindClose(SearchRec);
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  I:             Integer;
  Extensions, FileList: TStringList;
begin
  Screen.Cursor := crHourGlass;
  try
    FileList := TStringList.Create;
    try
      Extensions := TStringList.Create;
      try
        for I := 0 to CheckListBox1.Items.Count-1 do  // add extensions to search for
          if CheckListBox1.Checked[I] then
            Extensions.Add(CheckListBox1.Items.Strings[I]);
        FindMatchingFiles(IncludeTrailingPathDelimiter(btn1.text), Extensions, FileList);
      finally
        FreeAndNil(Extensions);
      end;
      if ((Edit1.Text <> '') or (Edit2.Text <> '')) and (FileList.Count > 0) then
        ProcessMatchingFiles(Edit1.Text, Edit2.Text, FileList);
      ListBox1.Items.Add('Done.');
      ListBox1.Items.Add('Replaced '+ edit1.Text+' in '+ IntToStr(FileList.Count)+' files');
    finally
      FreeAndNil(FileList);
    end;
  finally
    Screen.Cursor := crDefault;
  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!

 
LVL 7

Expert Comment

by:ahalya
ID: 23655643
A simpler option if you can live with it is to just show progress bar that restarts as needed until the job is done.  This way you don't have to know the "Max" value.

Just set Max to 100, and increment value by one for each file. Of course if value > 100, you reset value to 1.  not a perfect solution, but works, if your intent is to give some visual clue of progress.




0
 
LVL 19

Expert Comment

by:MerijnB
ID: 23657266
> A simpler option if you can live with it is to just show progress bar that restarts as needed until the job is done.

I find this always a very annoying solution :)
In that case try something like this: http://www.torry.net/vcl/indicat/meters/imgauge.zip

This is a progress gauge like you saw in netscape, it kind of swipes right and left, indicating activity but not saying anything about how far it is.
This is an old component, but I don't think you'd have much trouble using it in a recent version of Delphi.
0
 
LVL 38

Expert Comment

by:Geert Gruwez
ID: 23657313
it's like looking at the led display from the kit car from knight rider ...
for completenessity you should try and add that sound too  :)
0
 
LVL 19

Expert Comment

by:MerijnB
ID: 23657338
0
 

Author Comment

by:PeterdeB
ID: 23661975
@Geert > When I tried your code Delphi nagged about an EReadError concerning an invalid property value when reading button1.onClick.

When I moved the button1.onClick procedure outside the private section Delphi stopped nagging but then I had to reset the program because it kept showing the hourglass.

@others > if it will be too complex to implement this, I will forget about the progressbar but perhaps Geerts code will work ;-)

Greets Peter

One thing more > the original code would not search entire directories. For instance if I have a folder structure like this:

c:\blah1\blah2\blah3

And I would enter c:\blah1 as path it would only search files which reside in the folder blah1. and not dig deeper into the other folders.  


0
 
LVL 38

Expert Comment

by:Geert Gruwez
ID: 23662984
changing the name of the procedure would have solved it too ...
procedure TForm1.Btn1Click(Sender: TObject);

The name for Button1 got changed to Btn1.

And I would enter c:\blah1 as path it would only search files which reside in the folder blah1. and not dig deeper into the other folders.  
my guess is you need to use c:\blah1\ as path
0
 

Author Comment

by:PeterdeB
ID: 23663727
Hi geert,

Well I can't get it to work it keeps nagging about the invalid property value no matter what and how I try.

But alas.....regarding the other issue > you mean adding the slash would instruct it to dig deeper?

Regards Peter
0
 

Author Comment

by:PeterdeB
ID: 23663767
No it does not ;-) But can you tell me how to change the code to let it dig deeper?

Peter
0
 
LVL 38

Expert Comment

by:Geert Gruwez
ID: 23664842
did you try my code ?
if you ommit (= weglaten) the Replace_text instruction you should get a list of files
this way you could test the procedure
and see what files you get :
actually to make the button onclick work:
delete the Button1Click procedure (using the Ctrl-X feature, copy to clipboard)
double click the Button, thus adding a event handler for onClick
past the code back in remove the old header


if that still fails, show the line where the compiler complains
procedure TForm1.ProcessMatchingFiles(FindText, ReplaceText: string; FileList: TStrings);
var I: Integer;
begin
  //Progressbar.Max := FileList.Count;
  //Progressbar.Position := 0;
  for I := 0 to FileList.Count-1 do
  begin
    //Replace_Text(FileList[I], FindText, ReplaceText);
    ListBox1.Items.Add(FileList[I]);
    //Progressbar.Step(1);
  end;
end;
 
procedure TForm1.FindMatchingFiles(PathName: string; Extensions, FileList: TStrings);
var
  SearchRec:     TSearchRec;
 
  procedure CheckFile(aFileName: string);
  var I: Integer;
  begin
    if (aFileName[1] <> '.') then
    begin
      if SearchRec.Attr and faDirectory <> 0 then
        FindMatchingFiles(IncludeTrailingPathDelimiter(aFileName), Extensions, FileList)
      else
      begin
        if SearchRec.Attr and faArchive <> 0 then
          for I := 0 to Extensions.Count-1  do
            if SameText(ExtractFileExt(aFileName), Extensions[I]) then
            begin
              FileList.Add(aFileName);
              Break;
            end;
      end;
    end;
  end;
 
begin
  if FindFirst(PathName+'*.*', faAnyFile, SearchRec) = 0 then
  try
    CheckFile(PathName + SearchRec.Name);
    while FindNext(SearchRec) = 0 do
      CheckFile(PathName + SearchRec.Name);
  finally
    FindClose(SearchRec);
  end;
end;
 
procedure TForm1.Btn1Click(Sender: TObject);
var
  I:             Integer;
  Extensions, FileList: TStringList;
begin
  Screen.Cursor := crHourGlass;
  try
    FileList := TStringList.Create;
    try
      Extensions := TStringList.Create;
      try
        for I := 0 to CheckListBox1.Items.Count-1 do  // add extensions to search for
          if CheckListBox1.Checked[I] then
            Extensions.Add(CheckListBox1.Items.Strings[I]);
        FindMatchingFiles(IncludeTrailingPathDelimiter(btn1.text), Extensions, FileList);
      finally
        FreeAndNil(Extensions);
      end;
      if ((Edit1.Text <> '') or (Edit2.Text <> '')) and (FileList.Count > 0) then
        ProcessMatchingFiles(Edit1.Text, Edit2.Text, FileList);
      ListBox1.Items.Add('Done.');
      ListBox1.Items.Add('Replaced '+ edit1.Text+' in '+ IntToStr(FileList.Count)+' files');
    finally
      FreeAndNil(FileList);
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;
 
end.

Open in new window

0
 

Author Comment

by:PeterdeB
ID: 23673170
Hi Geert,

Delphi still stumbles upon the invalid prop value but it doesn't show a line number, so I used Eurekalog but that didnt help a thing.

Regards Peter

Exception:
-------------------------------------------------------------------------------
  2.1 Date          : Wed, 18 Feb 2009 19:23:29 +0100
  2.2 Address       : 0041DC9E
  2.3 Module Name   : MCR.exe
  2.4 Module Version:
  2.5 Type          : EReadError
  2.6 Message       : Error reading btnReplace.OnClick: Invalid property value.
  2.7 ID            : 555A
  2.8 Count         : 1
  2.9 Status        : New
  2.10 Note         :


0
 

Author Comment

by:PeterdeB
ID: 23673345
It works now, that is no compiler errors anymore. However it seems to hang right after the button click it keeps showing the hourglass.

Peter
0
 
LVL 38

Accepted Solution

by:
Geert Gruwez earned 2000 total points
ID: 23734400
change this:

  procedure CheckFile(aFileName: string);
  var I: Integer;
    xFileName: string;
  begin
    xFileName := ExtractFileName(aFileName);
    if (xFileName[1] <> '.') then
    begin
      if SearchRec.Attr and faDirectory <> 0 then
        FindMatchingFiles(IncludeTrailingPathDelimiter(aFileName), Extensions, FileList)
      else
      begin
        if SearchRec.Attr and faArchive <> 0 then
          for I := 0 to Extensions.Count-1  do
            if SameText(ExtractFileExt(aFileName), Extensions[I]) then
            begin
              FileList.Add(aFileName);
              Break;
            end;
      end;
    end;
  end;
0
 

Author Comment

by:PeterdeB
ID: 23736962
Thanks geert,

Peter
0

Featured Post

Upgrade your Question Security!

Add Premium security features to your question to ensure its privacy or anonymity. Learn more about your ability to control Question Security today.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The uses clause is one of those things that just tends to grow and grow. Most of the time this is in the main form, as it's from this form that all others are called. If you have a big application (including many forms), the uses clause in the in…
Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
This lesson discusses how to use a Mainform + Subforms in Microsoft Access to find and enter data for payments on orders. The sample data comes from a custom shop that builds and sells movable storage structures that are delivered to your property. …
Whether it be Exchange Server Crash Issues, Dirty Shutdown Errors or Failed to mount error, Stellar Phoenix Mailbox Exchange Recovery has always got your back. With the help of its easy to understand user interface and 3 simple steps recovery proced…
Suggested Courses

873 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question