Add a folder picker to a search and replace macro

Andreas Hermle
Andreas Hermle used Ask the Experts™
on
Dear Experts:

below macro does search and replace operations in nested subfolders.

The 'master folder' is hard coded on line 6. I wonder whether the macro can be tweaked to accommodate the following two requirements.

1. A folder picker is to let the user choose the 'master folder'
2. The built in Search and Replace Dialog is to appear where the user can enter his/her search and replace criteria.

Help is much appreciated.

Thank you very much in advance.

Regards, Andreas

I wonder whether somebody could

Sub x_SearchAndReplace_MultipleFiles_Folders_Subfolders()
Dim FSO As Object
Dim ROOT As Object
Dim fldr As Object
    
    Const strFolder = "C:\Trial\"
    Set FSO = CreateObject("scripting.filesystemobject")
    If Not FSO.folderexists(strFolder) Then
        MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
        Exit Sub
    End If
    Set ROOT = FSO.getfolder(strFolder & "\")
    processFolder ROOT.path
    For Each fldr In ROOT.subfolders
        processFolder fldr.path & "\"
    Next
    
End Sub

Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range
Dim fileSet As Object

    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = "15.500"
                        .Replacement.Text = "19.500"
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
NVITEnd-user support
Commented:
Try this. I added 2 functions: SelectFolder, and UserInput on lines 7, 8, 9.

Sub x_SearchAndReplace_MultipleFiles_Folders_Subfolders()

Dim FSO As Object
Dim ROOT As Object
Dim fldr As Object
    
strFolder = SelectFolder (“c:\”)
strFind = UserInput( "Find what:" )
strRepl = UserInput( "Replace with:" )

Set FSO = CreateObject("scripting.filesystemobject")
If Not FSO.folderexists(strFolder) Then
	MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
	Exit Sub
End If
Set ROOT = FSO.getfolder(strFolder & "\")
processFolder ROOT.path
For Each fldr In ROOT.subfolders
	processFolder fldr.path & "\"
Next    

End Sub



Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range
Dim fileSet As Object

    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = strFind
                        .Replacement.Text = strRepl
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub


Function SelectFolder( myStartFolder )
' This function opens a "Select Folder" dialog and will
' return the fully qualified path of the selected folder
'
' Argument:
'     myStartFolder    [string]    the root folder where you can start browsing;
'                                  if an empty string is used, browsing starts
'                                  on the local computer
'
' Returns:
' A string containing the fully qualified path of the selected folder
'
' Written by Rob van der Woude
' http://www.robvanderwoude.com

    ' Standard housekeeping
    Dim objFolder, objItem, objShell
    
    ' Custom error handling
    On Error Resume Next
    SelectFolder = vbNull

    ' Create a dialog object
    Set objShell  = CreateObject( "Shell.Application" )
    Set objFolder = objShell.BrowseForFolder( 0, "Select Folder", 0, myStartFolder )

    ' Return the path of the selected folder
    If IsObject( objfolder ) Then SelectFolder = objFolder.Self.Path

    ' Standard housekeeping
    Set objFolder = Nothing
    Set objshell  = Nothing
    On Error Goto 0
End Function

Function UserInput( myPrompt )
' This function prompts the user for some input.
' When the script runs in CSCRIPT.EXE, StdIn is used,
' otherwise the VBScript InputBox( ) function is used.
' myPrompt is the the text used to prompt the user for input.
' The function returns the input typed either on StdIn or in InputBox( ).
' Written by Rob van der Woude
' http://www.robvanderwoude.com
' Check if the script runs in CSCRIPT.EXE
If UCase( Right( WScript.FullName, 12 ) ) = "\CSCRIPT.EXE" Then
   ' If so, use StdIn and StdOut
   WScript.StdOut.Write myPrompt & " "
   UserInput = WScript.StdIn.ReadLine
Else
   ' If not, use InputBox( )
   UserInput = InputBox( myPrompt )
End If
End Function

Open in new window

Top Expert 2016
Commented:
Hi,

pls try
Sub x_SearchAndReplace_MultipleFiles_Folders_Subfolders()
Dim FSO As Object
Dim ROOT As Object
Dim fldr As Object
Dim strFolder

    Set FSO = CreateObject("scripting.filesystemobject")
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strFolder
        If .Show <> -1 Then
            MsgBox "Folder not selected - Exiting routine", , "Error"
        Exit Sub
        End If
        strFolder = .SelectedItems(1)
    End With
    If Not FSO.folderexists(strFolder) Or strFolder = "" Then
        MsgBox "Folder '" & strFolder & "' not found - Exiting routine", , "Error"
        Exit Sub
    End If
    With Application.Dialogs(wdDialogEditReplace)
        On Error Resume Next
        .Show
        On Error GoTo 0
        .Update
        strFind = .Find
        strReplace = .Replace
    End With
    Set ROOT = FSO.getfolder(strFolder & "\")
    processFolder ROOT.Path
    For Each fldr In ROOT.subfolders
        processFolder fldr.Path & "\"
    Next
    
End Sub

Sub processFolder(strFolder As String)
Dim strFile As String
Dim doc As Document
Dim rng As Word.Range
Dim fileSet As Object

    strFile = Dir$(strFolder & "*.docx")
    Do Until strFile = ""
        Set doc = Documents.Open(strFolder & strFile)
        
        For Each rng In doc.StoryRanges
        
                    With rng.Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = strFind
                        .Replacement.Text = strReplace
                        .Replacement.Font.Size = 9
                        .Forward = True
                        .Wrap = wdFindContinue
                        .Execute Replace:=wdReplaceAll
                    End With
                Next rng
        doc.Save
        doc.Close
        strFile = Dir$()
    Loop
End Sub

Open in new window

Regards
Andreas HermleTeam leader

Author

Commented:
Dear both,

thank you very much for your great and professional support.

Dear NVIT:
looks awesome. It is a pity that line 100-105 does not work on my machine, but I am sure this has something to do that I run the macro on my business computer at my company.
If UCase( Right( WScript.FullName, 12 ) ) = "\CSCRIPT.EXE" Then
   ' If so, use StdIn and StdOut
   WScript.StdOut.Write myPrompt & " "
   UserInput = WScript.StdIn.ReadLine
Else

Open in new window


I have to comment out all these lines, i.e. 100-105 for the macro to come up with the InputBoxes

The Input Boxes appear as desired, the strange thing is that whatever I enter as search and replace text, nothing is replaced. The files get opened and saved superfast, but no replacement action whatsoever. Any idea why?

Thank you and Regards, Andreas
OWASP: Forgery and Phishing

Learn the techniques to avoid forgery and phishing attacks and the types of attacks an application or network may face.

Andreas HermleTeam leader

Author

Commented:
Hi Rgonzo,

the folder picker works just fine, the search and replace dialog comes up but whatever I enter into the search and replace fields nothing gets updated. I am not quite sure whether this dialog field is working as part of a macro in the first place, since I am not able to confirm any settings with an OK button. I just am able to close it.

If I tweak your code and comment out line 23 till 30 and change line 54 and 55 accordingly, everything works fine.

Regards, Andreas
Top Expert 2016

Commented:
to use the built-in replace you have to first either click Replace or replace all then Close

if you remember the normal behavior of the replace Dialog is to stay open as long as it isn't closed

Regards
NVITEnd-user support

Commented:
Andreas... Just confirming... Your folder contains .docx files, as shown in first post, line 26?
Andreas HermleTeam leader

Author

Commented:
Dear both,

sorry for the delay in getting back to you.

Rgonzo: okay, will try it out and then let you know
NVIT: yes they are all docx-files
Andreas HermleTeam leader

Author

Commented:
Dear both,

having heeded your comments, the things I said before, I regret, are still valid, i.e.

@ NVIT:
looks awesome. It is a pity that line 100-105 do not work on my machine, ie.
... I get the error message: 424 runtime error. The following line gets highlighted:
If UCase( Right( WScript.FullName, 12 ) ) = "\CSCRIPT.EXE" (line 100)

I have to comment out all these lines, i.e. 100-105 for the macro to come up with the InputBoxes

The Input Boxes appear as desired, the strange thing is that whatever I enter as search and replace text, nothing is replaced. The files get opened and saved superfast, but no replacement action whatsoever.


@Rgonzo: I heeded your advice, i.e. I clicked replace / replace all, and then closed the dialog field.

But then, the macro loops thru all the files, open and closes them, but no replacement action whatsoever is completed. Strange isn't it. Anyhow the Folder Picker works great and this is the most important part for me.

Regards, Andreas
Andreas HermleTeam leader

Author

Commented:
Dear both,

I suggest splitting the points as I did. I tweaked both codes a little bit so now they work just fine.

Thank you very much for your great and professional help. I really appreciate it.

Regards, Andreas

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial