CODEWITHSUNDEEP
vbafilems-wordsave
Tomlawson94
Tomlawson94

Reputation: 1

How do i create a VB Macro that will save a certain file to all sub folders in a particular directory?

This is what I have so far, might be good might not haha!

I have been trying to save a word document to about 400+ folders without having to go through them all, can this be done through VB Macros? I got it working to just save it to the directory, but I cannot save it to all the Subfolders.

Dim FileSystem As Object
Dim HostFolder As String
Sub DoFolder(folder)
HostFolder = ("H:\test2")

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
    Dim SubFolder
    For Each SubFolder In folder.SubFolders
      DoFolder SubFolder
    Next
    Dim File
    For Each File In folder.Files
      Set FileSystem = CreateObject("Scripting.FileSystemObject")
      ' Operate on each file
      ActiveDocument.Save
    Next
End Sub

Upvotes: 0

Views: 112

Answers (2)

Comintern
Comintern

Reputation: 22195

Gotta love auditing requirements... You're basically on the right path, but you really only need one FileSystemObject. About the only errors I see are that you need the .Path of the folder here...

For Each SubFolder In folder.SubFolders
  DoFolder SubFolder.Path   '<---Here.
Next

...and you don't need to loop through all the files here (you may be overthinking this one a bit):

For Each File In folder.Files
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  ' Operate on each file
  ActiveDocument.Save
Next

Also, I'd suggest using early binding instead of late binding (although the example below can easily be switched). I'd do something a bit more like this:

Private Sub SaveDocToAllSubfolders(targetPath As String, doc As Document, _
                                   Optional root As Boolean = False)
    With New Scripting.FileSystemObject
        Dim current As Scripting.folder
        Set current = .GetFolder(targetPath)
        If Not root Then
            doc.SaveAs .BuildPath(targetPath, doc.Name)
        End If
        Dim subDir As Scripting.folder
        For Each subDir In current.SubFolders
            SaveDocToAllSubfolders subDir.Path, doc
        Next
    End With
End Sub

The root flag is just whether or not to save a copy in the host folder. Call it like this:

SaveDocToAllSubfolders "H:\test2", ActiveDocument, True

Upvotes: 2

user6432984
user6432984

Reputation:

I recommended reading: Chip Pearson -Recursion And The FileSystemObject

Make a recursive subroutine to iterate over all the subfolders (and their subfolders) in the root directory.

getAllSubfolderPaths: returns an array that lists all the sub folders in a folder.

Function getAllSubfolderPaths(FolderPath As String, Optional FSO As Object, Optional List As Object)
    Dim fld As Object

    If FSO Is Nothing Then
        Set FSO = CreateObject("Scripting.Filesystemobject")
        Set List = CreateObject("SYstem.Collections.ArrayList")
    End If

    List.Add FolderPath

    For Each fld In FSO.GetFolder(FolderPath).SubFolders
        getAllSubfolderPaths fld.Path, FSO, List
    Next

    getAllSubfolderPaths = List.ToArray
End Function

Test

Sub Test()
    Const RootFolder As String = "C:\Users\Owner\Pictures"
    Const SourcePath As String = "C:\Users\Owner\Documents\Youcam"
    Const SourceFileName As String = "Capture.PNG"

    Dim fld As Variant, FolderArray As Variant
    Dim Destination As String, Source As String

    FolderArray = getAllSubfolderPaths(RootFolder)

    For Each fld In FolderArray
        Destination = fld & "\" & SourceFileName
        Source = SourcePath & "\" & SourceFileName
        'Delete old copy of file
        If Destination <> Source And Len(Dir(Destination)) Then Kill Destination

        VBA.FileCopy Source:=Source, Destination:=Destination
    Next
End Sub

Upvotes: 2

Related Questions