VBA Word - Apply Macro to Directory

**saphire99** · 01-07-2016, 03:00 PM

Hello to all,

This great day / evening.

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/1...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

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.

Please do help, I am really grateful

thank you so much in advance for your time

Saphire

**gmaxey** · 01-07-2016, 06:55 PM

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.  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** · 01-07-2016, 08:09 PM

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** · 01-08-2016, 04:41 AM

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** · 01-08-2016, 07:21 AM

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 -

, it would be nice if that VBA editor gave me an alternative suggestion to the error - here is hoping.

Thank you

Saphire

**gmaxey** · 01-08-2016, 08:30 AM

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** · 01-08-2016, 09:01 AM

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** · 01-08-2016, 10:55 AM

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** · 01-08-2016, 11:46 AM

Hello Greg,

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

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/lib...=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

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

, 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

This is Solved

Thread: VBA Word - Apply Macro to Directory

Thread Tools

Display

VBA Word - Apply Macro to Directory

[SOLVED]

Posting Permissions