Ir ao conteúdo
  • Cadastre-se
cmalves

Compartilhando Informações Macro executa subpastas

Recommended Posts

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×