PDA

View Full Version : [SOLVED:] Progress Bar


gibbo1715
01-29-2005, 08:20 AM
Ok I have the code below to search through a number of word documents

Can anyone tell me how to add a simple progress bar when the code is running please

I ve looked at the one by DRJ at http://www.vbaexpress.com/kb/getarticle.php?kb_id=169

but cant figure out how to get it running with my code

I ve attached the worksheet for you to look at but if you open it you will need to create a sub directory called statements where the spreadsheet is saved

Many thanks for your help


Sub SearchStatements_Click()
Dim AppWrd As New Word.Application
Dim Doc As Word.Document
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim PageX() As Long
Dim LineX() As Long
Dim FPath() As String
Dim FName() As String
Dim Row As Long
Dim Counter As Long
Dim Pos As Double
Dim Path As String
Dim FileName As String
Dim MyResponse As VbMsgBoxResult
Dim StartLine As Long
Dim StartPage As Long
Dim ws As Worksheet
Dim x As Long
Dim Cell As Range
Dim Rng As Range
On Error GoTo Error
Path = ThisWorkbook.Path & "\Statements"
Prompt = "What do you want to search for?"
Title = "Search Criteria"
Search = InputBox(Prompt, Title)
If Search = "" Then
GoTo Canceled
End If
'*** Confirm the procedure before continuing ***
Prompt = "Are you sure that you want to search all the files in the folder:" & _
vbCrLf & Path & " for " & """" & Search & """" & "?"
Title = "Confirm Procedure"
MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title)
If MyResponse = vbNo Then
GoTo Canceled
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'*** Loop through all Word documents and search each of them for the specified criteria***
FileName = Dir(Path & "\*.doc", vbNormal)
Do Until FileName = ""
On Error Resume Next
Set Doc = AppWrd.Documents.Open(Path & "\" & FileName, ReadOnly:=True, _
PasswordDocument:="")
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
With Doc
AppWrd.Selection.Find.ClearFormatting
With AppWrd.Selection.Find
.Text = Search
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
On Error Resume Next
AppWrd.Selection.Find.Execute
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
If AppWrd.Selection.Range.Text <> Search Then
GoTo NextLoop:
End If
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
StartLine = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
StartPage = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
AppWrd.Selection.Find.Execute
Do While Pos <> AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Or _
StartLine <> AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) Or _
StartPage <> AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
If LineX(Counter - 1) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) And _
PageX(Counter - 1) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber) And _
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then
Exit Do
Else
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
AppWrd.Selection.Find.Execute
End If
Loop
NextLoop:
End With
Doc.Close False
Set Doc = Nothing
On Error GoTo 0
FileName = Dir()
Loop
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
GoTo Canceled
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("A1").Value = "Occurrences of the word " & """" & Search & """"
.Range("A1:C1").Merge
.Range("A2").Value = "Document Path"
.Range("B2").Value = "Page Number"
.Range("C2").Value = "Line Number"
.Range("A1:C2").Font.Bold = True
.Range("A1:C2").HorizontalAlignment = xlCenter
For Row = UBound(LineX) To 1 Step -1
If PageX(Row) = 0 Or LineX(Row) = 0 Then
Else
.Range("B" & Row + 2).Value = PageX(Row)
.Range("C" & Row + 2).Value = LineX(Row)
.Hyperlinks.Add Anchor:=.Range("A" & Row + 2), _
Address:=FPath(Row) & "\" & FName(Row), TextToDisplay:=FName(Row)
End If
Next Row
.Range("A:C").EntireColumn.AutoFit
End With
Canceled:
AppWrd.Quit
Set Doc = Nothing
Set AppWrd = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("Sheet1").Select
Exit Sub
Error:
MsgBox "The directory Statements does not exist at this location so a search is not possible"
End Sub


Help really is appreciated
Jacob Hilderbrand
01-29-2005, 04:24 PM
Ok, try this. Make a UserForm with two Text Boxes and one Label. Then add this code.


Option Explicit

Private Sub UserForm_Activate()
Application.Cursor = xlWait
ProgressBar.MousePointer = fmMousePointerHourGlass
DoEvents
Call CalculateData
Application.Cursor = xlDefault
Unload Me
End Sub

Private Sub UserForm_Initialize()
TextBox2.Left = TextBox1.Left
TextBox2.Top = TextBox1.Top + 3
TextBox2.Width = 0
End Sub

Sub CalculateData()
Dim Total1 As Long
Dim x As Long
Dim AppWrd As New Word.Application
Dim Doc As Word.Document
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim PageX() As Long
Dim LineX() As Long
Dim FPath() As String
Dim FName() As String
Dim Row As Long
Dim Counter As Long
Dim Pos As Double
Dim Path As String
Dim FileName As String
Dim MyResponse As VbMsgBoxResult
Dim StartLine As Long
Dim StartPage As Long
Dim ws As Worksheet
Dim Cell As Range
Dim Rng As Range
Dim FSO As Object
Dim f As Object
On Error GoTo Error
Path = ThisWorkbook.Path & "\Statements"
Prompt = "What do you want to search for?"
Title = "Search Criteria"
Search = InputBox(Prompt, Title)
If Search = "" Then
GoTo Canceled
End If
'*** Confirm the procedure before continuing ***
Prompt = "Are you sure that you want to search all the files in the folder:" & _
vbCrLf & Path & " for " & """" & Search & """" & "?"
Title = "Confirm Procedure"
MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title)
If MyResponse = vbNo Then
GoTo Canceled
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FilesystemObject")
Set f = FSO.getfolder(Path)
Total1 = f.Files.Count
'*** Loop through all Word documents and search each of them for the specified criteria***
FileName = Dir(Path & "\*.doc", vbNormal)
Do Until FileName = ""
x = x + 1
On Error Resume Next
Set Doc = AppWrd.Documents.Open(Path & "\" & FileName, ReadOnly:=True, _
PasswordDocument:="")
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
With Doc
AppWrd.Selection.Find.ClearFormatting
With AppWrd.Selection.Find
.Text = Search
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
On Error Resume Next
AppWrd.Selection.Find.Execute
If Err <> 0 Then
GoTo NextLoop:
End If
On Error GoTo 0
If AppWrd.Selection.Range.Text <> Search Then
GoTo NextLoop:
End If
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
StartLine = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
StartPage = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
AppWrd.Selection.Find.Execute
Do While Pos <> AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Or _
StartLine <> AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) Or _
StartPage <> AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
Counter = Counter + 1
ReDim Preserve LineX(1 To Counter)
ReDim Preserve PageX(1 To Counter)
ReDim Preserve FPath(1 To Counter)
ReDim Preserve FName(1 To Counter)
If LineX(Counter - 1) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber) And _
PageX(Counter - 1) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber) And _
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage) Then
Exit Do
Else
LineX(Counter) = AppWrd.Selection.Range.Information(wdFirstCharacterLineNumber)
PageX(Counter) = AppWrd.Selection.Range.Information(wdActiveEndPageNumber)
FPath(Counter) = Doc.Path
FName(Counter) = Doc.Name
Pos = AppWrd.Selection.Range.Information(wdHorizontalPositionRelativeToPage)
AppWrd.Selection.Find.Execute
End If
Loop
NextLoop:
End With
Doc.Close False
Set Doc = Nothing
On Error GoTo 0
ProgressBar.TextBox2.Width = (x / Total1) * 200
ProgressBar.Label1.Caption = "Updating: " & x & " of " & Total1
DoEvents
FileName = Dir()
Loop
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
GoTo Canceled
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("A1").Value = "Occurrences of the word " & """" & Search & """"
.Range("A1:C1").Merge
.Range("A2").Value = "Document Path"
.Range("B2").Value = "Page Number"
.Range("C2").Value = "Line Number"
.Range("A1:C2").Font.Bold = True
.Range("A1:C2").HorizontalAlignment = xlCenter
For Row = UBound(LineX) To 1 Step -1
If PageX(Row) = 0 Or LineX(Row) = 0 Then
Else
.Range("B" & Row + 2).Value = PageX(Row)
.Range("C" & Row + 2).Value = LineX(Row)
.Hyperlinks.Add Anchor:=.Range("A" & Row + 2), _
Address:=FPath(Row) & "\" & FName(Row), TextToDisplay:=FName(Row)
End If
Next Row
.Range("A:C").EntireColumn.AutoFit
End With
Canceled:
AppWrd.Quit
Set Doc = Nothing
Set AppWrd = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets("Sheet1").Select
Exit Sub
Error:
MsgBox "The directory Statements does not exist at this location so a search is not possible"
End Sub

See the attachment for an example.
gibbo1715
01-30-2005, 02:42 AM
Thanks Jake
Jacob Hilderbrand
01-30-2005, 04:27 AM
You're Welcome :beerchug:

Take Care