Loop Through All Word Documents in Directory

You can loop through all the *.doc files in a directory with this macro. This example was used to recover corrupted documents. The code opens the file, selects the whole document and copies it, pastes to a new document, and saves the file with the original name, but in a new directory. However by changing the highlighted section in the middle, you can perform any action on all the nominated documents.


Sub LoopThruFile()
Dim strPath As String
Dim strNewPath As String
Dim strFullPathDoc As String
Dim strFileName As String


strPath = "F:\Data\TestFolder\"
strNewPath = strPath & "Recovered\"

strFullPathDoc = Dir(strPath & "*.doc", vbNormal)

Do While strFullPathDoc <> ""
strFileName = ExtractFileName(strFullPathDoc)

Documents.Open strPath & strFileName

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Change this section to perform a different action

Selection.WholeStory
Selection.Copy
Documents.Add Template:="Normal", NewTemplate:=False
Selection.Paste
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

' Depending on what you're doing, you may want to use Save rather than SaveAs
' use this option to save to a different location

ActiveDocument.SaveAs strNewPath & strFileName
ActiveWindow.Close

strFullPathDoc = Dir ' Get next entry.
Loop
End Sub

Function ExtractFileName(strFullPath As String)
Dim txt As String


On Error Resume Next

txt = "" & strFullPath

While InStr(txt, "\") > 0
txt = Mid$(txt, InStr(txt, "\") + 1)
Wend

If InStr(txt, ":") > 0 Then
txt = Mid$(txt, InStr(txt, ":") + 1)
End If

ExtractFileName = txt
End Function