How do I mass-extract email addresses out of several word documents at once?

Insert

oNewDoc.Range.Tables(1).Cell(1, 1).Range.InsertBefore strPath

between

oNewDoc.Range.ConvertToTable

and

oNewDoc.Range.Tables(1).Select

Doug, many thanks. That worked beautifully!

It's incredible how helpful you are.

My deepest respect.

I'd like to share my slightly modified (amateurish but still may be of use to somebody) variant:

Changes:

1. Part of the path where folder selection dialog starts can be fixed, so you won't have to go through all directory structure again and again
2. Removes .doc* extension from the filenames it saves
3. Copies result (table) in clipboard and quits after completion

I'd like to add one more feature - save the name of the chosen folder (with all *.doc files) in the first row (left cell) of the table but haven't figured it yet.)

Sub BatchProcess()

Application.ScreenUpdating = True

Dim strFilename As String

Dim strPath As String

Dim oDoc As Document

Dim oNewDoc As Document

Dim oRng As Range

Dim hLink As Hyperlink

Dim fDialog As FileDialog

Set oNewDoc = Documents.Add

Options.AutoFormatReplaceHyperlinks = True

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog

    .Title = "Select folder containing the documents and click OK"

    .AllowMultiSelect = False

    .InitialFileName = "C:\Your path here" & ""

    If .Show <> -1 Then

        MsgBox "Cancelled By User", , _

               "List Folder Contents"

        Exit Sub

    End If

    strPath = fDialog.SelectedItems.Item(1)

    If Right(strPath, 1) <> "" _

       Then strPath = strPath + ""

End With

If Left(strPath, 1) = Chr(34) Then

    strPath = Mid(strPath, 2, Len(strPath) - 2)

End If

strFilename = Dir$(strPath & "*.doc?")

While Len(strFilename) <> 0

    WordBasic.DisableAutoMacros 1

    Set oDoc = Documents.Open(strPath & strFilename)

    oDoc.Range.AutoFormat

    For Each hLink In oDoc.Hyperlinks

        If InStr(1, hLink.Address, "@") Then

            oNewDoc.Range.InsertAfter oDoc.Name & vbTab & hLink.Range & vbCr

        End If

    Next hLink

    oDoc.Close SaveChanges:=wdDoNotSaveChanges

    WordBasic.DisableAutoMacros 0

    strFilename = Dir$()

Wend

oNewDoc.Paragraphs.Last.Range.Delete

oNewDoc.Range.Sort

oNewDoc.Range.Find.Execute FindText:="(*^13)@", _

                           MatchWildcards:=True, _

                           ReplaceWith:="\1", _

                           Replace:=wdReplaceAll

oNewDoc.Range.Find.Execute FindText:=".doc*", _

                           MatchWildcards:=True, _

                           ReplaceWith:="", _

                           Replace:=wdReplaceAll

oNewDoc.Range.ConvertToTable

oNewDoc.Range.Tables(1).Select

Selection.Copy

ActiveWindow.Close

Application.Quit

End Sub

Use:

Sub BatchProcess()

Dim strFilename As String

Dim strPath As String

Dim oDoc As Document

Dim oNewDoc As Document

Dim oRng As Range

Dim hLink As Hyperlink

Dim fDialog As FileDialog

Set oNewDoc = Documents.Add

Options.AutoFormatReplaceHyperlinks = True

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog

    .Title = "Select folder containing the documents and click OK"

    .AllowMultiSelect = False

    .InitialView = msoFileDialogViewList

    If .Show <> -1 Then

        MsgBox "Cancelled By User", , _

               "List Folder Contents"

        Exit Sub

    End If

    strPath = fDialog.SelectedItems.Item(1)

    If Right(strPath, 1) <> "" _

       Then strPath = strPath + ""

End With

If Left(strPath, 1) = Chr(34) Then

    strPath = Mid(strPath, 2, Len(strPath) - 2)

End If

strFilename = Dir$(strPath & "*.doc?")

While Len(strFilename) <> 0

    WordBasic.DisableAutoMacros 1

    Set oDoc = Documents.Open(strPath & strFilename)

    oDoc.Range.AutoFormat

    For Each hLink In oDoc.Hyperlinks

        If InStr(1, hLink.Address, "@") Then

            oNewDoc.Range.InsertAfter oDoc.Name & vbTab & hLink.Range & vbCr

        End If

    Next hLink

    oDoc.Close SaveChanges:=wdDoNotSaveChanges

    WordBasic.DisableAutoMacros 0

    strFilename = Dir$()

Wend

oNewDoc.Paragraphs.Last.Range.Delete

oNewDoc.Range.Sort

oNewDoc.Range.Find.Execute FindText:="(*^13)@", _

                           MatchWildcards:=True, _

                           ReplaceWith:="\1", _

                           Replace:=wdReplaceAll

oNewDoc.Range.ConvertToTable

End Sub

Thanks.

You provided correction to original macros but I should say that original macros works fine with .doc.

It won't do filenames, which is exactly the reason I asked for help on this forum.

Your function is more advanced, it extracts filenames as well as e-mail addresses I suppose but it's working only with .docx type.

And it happens so that I need to process multiple .doc files.

Any help and assistance to solve this complication would be invaluable.