VBA Word - Apply Macro to Directory

[saphire99]

Hello to all,

This great day / evening. :hi:


I have been trying to fix this problem - not very well it seems.


I have a macro that I would like to apply to a directory of docx files. This seems simple enough as the below macro works nicely but only at the first level of files.

I would like to select my folder and apply it to all sub directories too.

I tried so many different things -


I referenced this thread - as well as a few others

http://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory
(http://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory)

But I am confused now about this file system object

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Set FSO = CreateObject("Scripting.FileSystemObject")


I have decided not to anger the code any more and need some expert help.:)






Sub Applytoallffiles()
Dim file
Dim path As String

path = "C:\Users\Desktop\Folder\" ' Path to the folder - include the terminating "\"

file = Dir(path & "*.docx") ' File extensions html,rtf or docx
Do While file <> ""
Documents.Open Filename:=path & file



Call myMacro


ActiveDocument.Save
ActiveDocument.Close
' Set file to next in Dir
file = Dir()
Loop
End Sub



(http://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory)

I just want to be able to select a directory and run my macro on it - but it seems too hard for me to do.

I have seen a lot of similar threads - but I can't get anything to work for me as some of them want you to convert a sub to a function , and I have lots of macros - I just don't know how to convert these complex subs to functions. :nervous::crying:


Please do help, I am really grateful

thank you so much in advance for your time

Saphire

[gmaxey]

Something like this:


Option Explicit
Private FSO, oFolder, oFile
Sub LoopThroughFolder()
Dim strMainFolder As String
strMainFolder = BrowseForFolder()
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strMainFolder)
On Error Resume Next
For Each oFile In oFolder.Files
Debug.Print oFile.Path
Next
'Get subdirectories
RecursiveFolder oFolder
Set FSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
'On Error Resume Next
For Each oFile In SubFld.Files
Debug.Print oFile.Path
Next
RecursiveFolder SubFld
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim oShell As Object
'Create a file browser window at the default folder
Set oShell = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = oShell.self.Path
On Error GoTo 0
Set oShell = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename (file://\\servername\sharename). All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function

[saphire99]

Hello Greg,

Happy new year, and thank you for helping me today.


Please forgive my ignorance for not knowing where to put the macro.

Do I put my macro like this




For Each oFile In oFolder.Files


Call FormatParagraphs



And

For Each oFile In SubFld.Files

Call FormatParagraphs





or am I able to copy the block of code within this.



Thank you for helping me :)

Saphire

[gmaxey]

Saphire,

You will have to revise the code to actually open the document and the process the document directly or pass it to procedure that takes a Word.Document class object as an argument:


Option Explicit
Private oDoc As Document
Private FSO, oFolder, oFile
Sub LoopThroughFolder()
Dim strMainFolder As String
strMainFolder = BrowseForFolder()
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strMainFolder)
On Error Resume Next
For Each oFile In oFolder.Files
Set oDoc = Documents.Open(oFile.Path, , , False, , , , , , , , False)
SomeMacroThatTakesAObjectArgument oDoc
oDoc.Close wdSaveChanges
Next
'Get subdirectories
RecursiveFolder oFolder
Set FSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
For Each oFile In SubFld.Files
Set oDoc = Documents.Open(oFile.Path, , , False, , , , , , , , False)
SomeMacroThatTakesAObjectArgument oDoc
oDoc.Close wdSaveChanges
Next
RecursiveFolder SubFld
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim oShell As Object
'Create a file browser window at the default folder
Set oShell = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = oShell.self.Path
On Error GoTo 0
Set oShell = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub SomeMacroThatTakesAObjectArgument(oDocPassed As Word.Document)
MsgBox oDocPassed.Name
End Sub


For example you might change your Sub FormatParagrphs to Sub FormatParagraphs(oDoPassed As Word.Document)

[saphire99]

Hello Greg,

thank you for this extensive revised code. :)

Does the below look correct, I simply replaced the macro name.

The compiler said ambiguous name detected FormatParagraphs.





Option Explicit
Private oDoc As Document
Private FSO, oFolder, oFile
Sub LoopThroughFolder()
Dim strMainFolder As String
strMainFolder = BrowseForFolder()
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strMainFolder)
On Error Resume Next
For Each oFile In oFolder.Files
Set oDoc = Documents.Open(oFile.path, , , False, , , , , , , , False)

FormatParagraphs oDoc


oDoc.Close wdSaveChanges
Next
'Get subdirectories
RecursiveFolder oFolder
Set FSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
lbl_Exit:
Exit Sub
End Sub


Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
For Each oFile In SubFld.Files
Set oDoc = Documents.Open(oFile.path, , , False, , , , , , , , False)

FormatParagraphs oDoc

oDoc.Close wdSaveChanges
Next
RecursiveFolder SubFld
Next
End Sub




Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim oShell As Object
'Create a file browser window at the default folder
Set oShell = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = oShell.self.path
On Error GoTo 0
Set oShell = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function


Sub FormatParagraphs(oDocPassed As Word.Document)
MsgBox oDocPassed.Name
End Sub




Sub FormatParagraphs()


Dim oPara As Paragraph
For Each oPara In ActiveDocument.Paragraphs

oPara.Range.Shading.BackgroundPatternColor = RGB(220, 180, 250)

Next

End Sub



Or Should I put my macro in another module. I apologize for the newbie questions - :blush, it would be nice if that VBA editor gave me an alternative suggestion to the error - here is hoping.


Thank you :grinhalo:

Saphire

[gmaxey]

Saphire,

That error occurs because you have two procedures name "FormatParagraphs". It is a bit like saying "Hey Saphire" in a room full of folks named Saphire and ambiguous as to which person named Saphire you are calling for.

Put the code you wanted executed in the one that takes the document object argument and delete the other one.

[saphire99]

Hello Greg,

hope you are doing great this Friday :)


Thank you for the pointer I hope I did as you requested




Option Explicit
Private oDoc As Document
Private FSO, oFolder, oFile
Sub LoopThroughFolder()
Dim strMainFolder As String
strMainFolder = BrowseForFolder()
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strMainFolder)
On Error Resume Next
For Each oFile In oFolder.Files
Set oDoc = Documents.Open(oFile.path, , , False, , , , , , , , False)

FormatParagraphs oDoc


oDoc.Close wdSaveChanges
Next
'Get subdirectories
RecursiveFolder oFolder
Set FSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
For Each oFile In SubFld.Files
Set oDoc = Documents.Open(oFile.path, , , False, , , , , , , , False)

FormatParagraphs oDoc

oDoc.Close wdSaveChanges
Next
RecursiveFolder SubFld
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim oShell As Object
'Create a file browser window at the default folder
Set oShell = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = oShell.self.path
On Error GoTo 0
Set oShell = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function


Sub FormatParagraphs(oDocPassed As Word.Document)


Dim oPara As Paragraph

For Each oPara In ActiveDocument.Paragraphs

oPara.Range.Shading.BackgroundPatternColor = RGB(220, 180, 250)
Next

'MsgBox oDocPassed.Name



End Sub




The VBA ran, but it did not apply the shading. I have done something wrong

Please do advise

Thank you so much for your help :)

Saphire

[gmaxey]

There comes a point where should be able to look at the code and deduce for yourself what the possible issue is:


Sub FormatParagraphs(oDocPassed As Word.Document)
'oDocPassed is the document that you opened from the folder.
'Process it.
Dim oPara As Paragraph
For Each oPara In oDocPassed.Paragraphs
oPara.Range.Shading.BackgroundPatternColor = RGB(220, 180, 250)
Next
End Sub

[saphire99]

Hello Greg,


I am happy to report thanks to all your help - we have lift off. :biggrin:

Well it would have lifted off hours ago but I tried fiddling about with the wrong code to no avail, newbie skills are no match for this.

I found this thread but that was of no help.

https://msdn.microsoft.com/en-us/library/bxa9y69d%28v=vs.90%29.aspx


I have folders within folders and removing files from them, then replacing them in the wrong folders as I was using the baby predecessor macro was becoming a big problem.


This VBA module is phenomenal - I love it!

I can process all my docx in sub folders - yipee :biggrin:

Thank you for persevering with me.

I have been looking for this for months - I tried at least a dozen ones found - they all let me down :crying:, or I let them down

I can't thank you enough for your help.

You are a star!

I hope you will have a smashing weekend!

Saphire
xo



:wavey:



This is Solved