Compartilhando Informações Macro executa subpastas

[cmalves]

Boa tarde

Caros Colegas

Estou postando um código que pode ser útil para muitas pessoas que precisarem. Trata-se de um código que executa a macro nas pastas e subpastas. 

Espero que possa ser útil para alguém....

Abraços

 

 

 

Option Explicit

 

Dim scrFso As Object                    'a FileSystemObject

Dim scrFolder As Object                 'the folder object

Dim scrSubFolders As Object             'the subfolders collection

Dim scrFile As Object                   'the file objectr

Dim scrFiles As Object                  'the files objectr

 

Sub OpenAllFilesInFolder()

    ' by brian balster 02/20/2003

    'starting place for trav macro

    'strStartPath is a path to start the traversal on

    Dim strStartPath As String

    strStartPath = "C:\Users\Desktop\Trab\"

    

    'stop the screen flickering

    Application.ScreenUpdating = False

    

    'open the files in the start folder

    OpenAllFiles strStartPath

    'search the subfolders for more files

    SearchSubFolders strStartPath

    

    'turn updating back on

    Application.ScreenUpdating = True

    

End Sub

Sub SearchSubFolders(strStartPath As String)

    'macro by brian balster 02/20/20/03

    'starts at path strStartPath and traverses its subfolders and files

    'if there are files below it calls OpenAllFiles, which opens them one by one

    'once its checked for files, it calls itself to check for subfolders.

    

    If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")

    Set scrFolder = scrFso.getfolder(strStartPath)

    Set scrSubFolders = scrFolder.subfolders

    For Each scrFolder In scrSubFolders

        Set scrFiles = scrFolder.Files

        If scrFiles.Count > 0 Then OpenAllFiles scrFolder.Path    'if there are files below, call openFiles to open them

        SearchSubFolders scrFolder.Path                                  'call ourselves to see if there are subfolders below

    Next

    

End Sub

 

Sub OpenAllFiles(strPath As String)

    '

    ' Macro created 9/17/2002 by brian-balster

    ' runs through a folder oPath, opening each file in that folder,

    ' calling a macro called samp, and then closing each file in that folder

    Dim strName As String

    Dim wdDoc As Document

    

    If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")

    Set scrFolder = scrFso.getfolder(strPath)

    For Each scrFile In scrFolder.Files

        strName = scrFile.Name              'the name of this file

        Application.StatusBar = strPath & "\" & strName   'the status bar is just to let us know where we are

        'we'll open the file fName if it is a word document or template

        If Right(strName, 4) = ".doc" Or Right(strName, 4) = ".dot" Then

            Set wdDoc = Documents.Open(FileName:=strPath & "\" & strName, _

            ReadOnly:=False, Format:=wdOpenFormatAuto)

            

            'Call the macro that performs work on the file pasing a reference to it

            DoWork wdDoc

            

            'we close saving changes

            wdDoc.Close wdSaveChanges

        End If

    Next

    

    'return control of status bar to Word

    Application.StatusBar = False

End Sub

 

Sub DoWork(wdDoc As Document)

    'this is where a macro would be that would actually do something

   Call macro4

   

End Sub