Solved

VBA Macro: Traverse through subfolders

Posted on 2008-10-16
7
2,381 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
  • 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 500 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
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
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

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Nice table. Huge mess. Maybe this was something you created way back before you figured out tabs or a document you received from someone else. Either way, using the spacebar to separate the columns resulted in a mess. Trying to convert text to t…
This article describes how to use the Send to Mail Recipient command. The instructions apply generally to Office 2007 and later versions, but Microsoft® Word 2013 was used for the specific steps and figures.  What is Send to Mail Recipient? Send…
This video shows and describes the main difference between both orientations in Microsoft Word. Viewers will understand when to use each orientation and how to get the most out of them.
In a previous video Micro Tutorial here at Experts Exchange (http://www.experts-exchange.com/videos/1358/How-to-get-a-free-trial-of-Office-365-with-the-Office-2016-desktop-applications.html), I explained how to get a free, one-month trial of Office …

759 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now