×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!
  • Students Click Here
*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Jobs
Home > Forums > MIS/IT > Office Suites > Microsoft: Office > FAQs

Microsoft: Office FAQ

VB for apps

Loop Through All Word Documents in Directory by GeekGirlau
faq68-1223
Posted: 30 Oct 01

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

Back to Microsoft: Office FAQ Index
Back to Microsoft: Office Forum

My Archive
Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close