Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

VBA Macro: Traverse through subfolders

Posted on 2008-10-16
7
Medium Priority
?
2,411 Views
Last Modified: 2010-04-21
Hello
The following script (thanks to Jeews) modifies the Word documents in the given path to change the attached template. It fits my needs perfectly, except that it modifies only the files in the given folder and it's subfolders. I need to go through the whole directory structure, not only one "folder layer". The code should modify all of the .doc's in all subfolders, even in it's subfolders and so on...
Thank you.
Word 2003
Public PcLogFileName As String
Public PcError As String
 
Sub CallChangeTemplates()
    Dim lcCurrentDir As String
 
 
    lcCurrentDir = "C:\Documents and Settings\URathnayake\My Documents\Expert Exchange\Skip write - Password protected"
 
    PcLogFileName = lcCurrentDir + "\" + "DocumentAccessSummery.txt"
 
 
    ChangeTemplates lcCurrentDir, "*.doc*"
  
End Sub
 
Sub ChangeTemplates(lcFilePath As String, strFilePattern As String)
    
    Dim loFileSystemObject, loDirectoryList As Object
    Dim lcLogString, lcChildDirectoryName, lcDirectoryPath, lcFileName, lcFileFullPath As String
    
 
     ' Create an object form the filesystem object
    Set loFileSystemObject = CreateObject("Scripting.FileSystemObject")
    
          
    ' Get the list of clients. Note: Folders should be named with the patner names
    Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
    
    
    Set loFileList = loFileSystemObject.GetFolder(lcFilePath).Files
        
        
        ' Traverse through the files
        For Each loFile In loFileList
        
            ' Get the file name to a variable to be used below
            lcFileName = loFile.Name
            
            ' Check only for excel fiels
            If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
                
                ' Construct the full path of the document
                lcFileFullPath = lcFilePath & "\" & lcFileName
            
                 ' Check whether the file is open
                If Not IsFileOpen(lcFileFullPath) Then
                
                    ' Checks the file is password protected
                    On Error Resume Next
                   Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
                        
                     ' File is password protected
                    If Err > 0 Then
                        Update_Log ("File: " + lcFileFullPath + " is Password protected.")
                    Else
                        Doc.AttachedTemplate = NormalTemplate
                        Doc.Close wdSaveChanges
                    End If
                    
                Else
                    
                    Update_Log ("File: " + lcFileFullPath + " is in use.")
                End If
            End If
 
        Next
    
    
 
    ' Traverse to each client folder to check get the available reports
    For Each loDirectory In loDirectoryList
    
        ' Get the Name of the processing client
        lcChildDirectoryName = loDirectory.Name
        
        ' Get the full path of the client directory
        lcDirectoryPath = loDirectory.Path
        
        ' Get the list of files under the client folder to be searched for MSR reports and procees with the updating
        Set loFileList = loFileSystemObject.GetFolder(lcDirectoryPath).Files
        
        
        ' Traverse through the files
        For Each loFile In loFileList
        
            ' Get the file name to a variable to be used below
            lcFileName = loFile.Name
            
            ' Check only for word fiels without the temporary files
            If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
                
                ' Construct the full path of the document
                lcFileFullPath = lcDirectoryPath & "\" & lcFileName
            
                ' Check whether the file is open
                If Not IsFileOpen(lcFileFullPath) Then
                    
                    ' Checks the file is password protected
                    On Error Resume Next
                    Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
                    
                        
                    ' File is password protected
                    If Err > 0 Then
                        Update_Log ("File: " + lcFileFullPath + " is Password protected.")
                    Else
                        Doc.AttachedTemplate = NormalTemplate
                        Doc.Close wdSaveChanges
                    End If
                    
                Else
                    
                    Update_Log ("File: " + lcFileFullPath + " is in use.")
                End If
            End If
 
        Next
    Next
 
    loFileSystemObject.Delete
    loDirectoryList.Delete
 
End Sub
 
Function IsFileOpen(lcFileName As String)
 
    Dim lnFileNum As Integer, lnErrNum As Integer
 
    On Error Resume Next   ' Turn error checking off.
    lnFileNum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open lcFileName For Input Lock Read As #lnFileNum
    Close lnFileNum          ' Close the file.
    lnErrNum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
 
    ' Check to see which error occurred.
    Select Case lnErrNum
 
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
 
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
 
        ' Another error occurred.
        Case Else
            Error lnErrNum
    End Select
 
End Function
 
Function Update_Log(lcString As String)
    
    
    If Not IsEmpty(lcString) Then
        lcString = FormatDateTime(Date, vbLongDate) + " : " + FormatDateTime(Time, vbLongTime) + " : " + lcString
        
        cfilename = FreeFile()
      
        
        On Error Resume Next
        Open PcLogFileName For Append As cfilename
        
        
        Print #cfilename, lcString
        Close #cfilename
        
        Err
    End If
 
End Function

Open in new window

0
Comment
Question by:chassouna
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
7 Comments
 
LVL 6

Expert Comment

by:Jeews
ID: 22738638
Hay hope this is what you are looking for

Please let me know if you need further assistance

Public PcLogFileName As String
Public PcError As String
Public loFileSystemObject As Object
 
Sub CallChangeTemplates()
    Dim lcCurrentDir As String
 
 
    lcCurrentDir = "c:\temp\docs"
 
    PcLogFileName = lcCurrentDir + "\" + "DocumentAccessSummery.txt"
 
 
    ChangeTemplates lcCurrentDir, "*.doc*"
  
End Sub
 
Sub ChangeTemplates(lcFilePath As String, strFilePattern As String)
    
    Dim loDirectoryList As Object
    Dim lcLogString, lcChildDirectoryName, lcDirectoryPath, lcFileName, lcFileFullPath As String
    
 
     ' Create an object form the filesystem object
    Set loFileSystemObject = CreateObject("Scripting.FileSystemObject")
    
          
    ' Get the list of clients. Note: Folders should be named with the patner names
    Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
    
    For Each loDirectory In loDirectoryList
      lcReturn = ListSubFolders(loDirectory.Path)
    Next
    
End Sub
 
Function IsFileOpen(lcFileName As String)
 
    Dim lnFileNum As Integer, lnErrNum As Integer
 
    On Error Resume Next   ' Turn error checking off.
    lnFileNum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open lcFileName For Input Lock Read As #lnFileNum
    Close lnFileNum          ' Close the file.
    lnErrNum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
 
    ' Check to see which error occurred.
    Select Case lnErrNum
 
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
 
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
 
        ' Another error occurred.
        Case Else
            Error lnErrNum
    End Select
 
End Function
 
Function Update_Log(lcString As String)
    
    
    If Not IsEmpty(lcString) Then
        lcString = FormatDateTime(Date, vbLongDate) + " : " + FormatDateTime(Time, vbLongTime) + " : " + lcString
        
        cfilename = FreeFile()
      
        
        On Error Resume Next
        Open PcLogFileName For Append As cfilename
        
        
        Print #cfilename, lcString
        Close #cfilename
        
        Err
    End If
 
End Function
 
Function ListSubFolders(lcFilePath As String)
 
    UpdateFiles (lcFilePath)
 
    On Error Resume Next
    ' Get the list of clients. Note: Folders should be named with the patner names
    Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
    
    For Each loDirectory In loDirectoryList
    
        
        ListSubFolders (loDirectory.Path)
 
    Next
End Function
 
Function UpdateFiles(lcFilePath As String)
 
    Dim lcFileFullPath As String
 
    Set loFileList = loFileSystemObject.GetFolder(lcFilePath).Files
        
        
    ' Traverse through the files
    For Each loFile In loFileList
    
        ' Get the file name to a variable to be used below
        lcFileName = loFile.Name
        
        ' Check only for excel fiels
        If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
            
            ' Construct the full path of the document
            lcFileFullPath = lcFilePath & "\" & lcFileName
        
             ' Check whether the file is open
            If Not IsFileOpen(lcFileFullPath) Then
            
                ' Checks the file is password protected
                On Error Resume Next
               Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
                    
                 ' File is password protected
                If Err > 0 Then
                    Update_Log ("File: " + lcFileFullPath + " is Password protected.")
                Else
                    Doc.AttachedTemplate = NormalTemplate
                    Doc.Close wdSaveChanges
                End If
                
            Else
                
                Update_Log ("File: " + lcFileFullPath + " is in use.")
            End If
        End If
 
    Next
 
End Function

Open in new window

0
 
LVL 6

Accepted Solution

by:
Jeews earned 2000 total points
ID: 22739081
Please insert the below line in the Line 30 of the above code

UpdateFiles (lcFilePath)

I'll anyway upload the updated code for you


Public PcLogFileName As String
Public PcError As String
Public loFileSystemObject As Object
 
Sub CallChangeTemplates()
    Dim lcCurrentDir As String
 
 
    lcCurrentDir = "c:\temp\docs"
 
    PcLogFileName = lcCurrentDir + "\" + "DocumentAccessSummery.txt"
 
 
    ChangeTemplates lcCurrentDir, "*.doc*"
  
End Sub
 
Sub ChangeTemplates(lcFilePath As String, strFilePattern As String)
    
    Dim loDirectoryList As Object
    Dim lcLogString, lcChildDirectoryName, lcDirectoryPath, lcFileName, lcFileFullPath As String
    
 
     ' Create an object form the filesystem object
    Set loFileSystemObject = CreateObject("Scripting.FileSystemObject")
    
          
    ' Get the list of clients. Note: Folders should be named with the patner names
    Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
    
    UpdateFiles (lcFilePath)
    
    For Each loDirectory In loDirectoryList
      lcReturn = ListSubFolders(loDirectory.Path)
    Next
    
End Sub
 
Function IsFileOpen(lcFileName As String)
 
    Dim lnFileNum As Integer, lnErrNum As Integer
 
    On Error Resume Next   ' Turn error checking off.
    lnFileNum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open lcFileName For Input Lock Read As #lnFileNum
    Close lnFileNum          ' Close the file.
    lnErrNum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
 
    ' Check to see which error occurred.
    Select Case lnErrNum
 
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
 
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
 
        ' Another error occurred.
        Case Else
            Error lnErrNum
    End Select
 
End Function
 
Function Update_Log(lcString As String)
    
    
    If Not IsEmpty(lcString) Then
        lcString = FormatDateTime(Date, vbLongDate) + " : " + FormatDateTime(Time, vbLongTime) + " : " + lcString
        
        cfilename = FreeFile()
      
        
        On Error Resume Next
        Open PcLogFileName For Append As cfilename
        
        
        Print #cfilename, lcString
        Close #cfilename
        
        Err
    End If
 
End Function
 
Function ListSubFolders(lcFilePath As String)
 
    UpdateFiles (lcFilePath)
 
    On Error Resume Next
    ' Get the list of clients. Note: Folders should be named with the patner names
    Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
    
    For Each loDirectory In loDirectoryList
    
        
        ListSubFolders (loDirectory.Path)
 
    Next
End Function
 
Function UpdateFiles(lcFilePath As String)
 
    Dim lcFileFullPath As String
 
    Set loFileList = loFileSystemObject.GetFolder(lcFilePath).Files
        
        
    ' Traverse through the files
    For Each loFile In loFileList
    
        ' Get the file name to a variable to be used below
        lcFileName = loFile.Name
        
        ' Check only for excel fiels
        If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
            
            ' Construct the full path of the document
            lcFileFullPath = lcFilePath & "\" & lcFileName
        
             ' Check whether the file is open
            If Not IsFileOpen(lcFileFullPath) Then
            
                ' Checks the file is password protected
                On Error Resume Next
               Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
                    
                 ' File is password protected
                If Err > 0 Then
                    Update_Log ("File: " + lcFileFullPath + " is Password protected.")
                Else
                    Doc.AttachedTemplate = NormalTemplate
                    Doc.Close wdSaveChanges
                End If
                
            Else
                
                Update_Log ("File: " + lcFileFullPath + " is in use.")
            End If
        End If
 
    Next
 
End Function

Open in new window

0
 

Author Comment

by:chassouna
ID: 22739387
Very good, now all documents in every subfolder are processed. But now the documents in the root folder stay unchanged (that files that resides just in the folder we define in line 9). I think this is a small code change (as it worked in the previous code).
Thank you!
0
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 6

Expert Comment

by:Jeews
ID: 22739407
I have done that change also in the previous post please check
0
 

Author Closing Comment

by:chassouna
ID: 31507042
I'm very thankful for your assistance, Jeews. You saved me a lot of time. Thank you!
0
 

Author Comment

by:chassouna
ID: 22739465
Ups, I copied the code without the supplemented line...
I'm very thankful for your assistance, Jeews. You saved me a lot of time. Thank you!
0
 
LVL 6

Expert Comment

by:Jeews
ID: 22739501
You are always welcome chassouna :-)
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you work with Word a lot, you probably use styles. If you use styles a lot, you've probably balled your fist more often than not when working with the ribbon. In Word 2007/2010, one of the things that I find missing when using styles is a quic…
A few years ago I was very much a beginner at VBA, and that very much remains the case today.  I'll do my best to explain things as I go in the hope that other beginners can follow.  If you just want to check out a tool that creates a Select Case fu…
This video shows the viewer how to set up and create Footnotes in their document. Click on the References tab: Select "Insert Footnote": Type in desired text:
This Micro Tutorial well show you how to find and replace special characters in Microsoft Word. This is similar to carriage returns to convert columns of values from Microsoft Excel into comma separated lists.

704 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question