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

It is not possible to extract the e-mail addresses without opening the documents, but the process can be automated with a macro. The following may do what you want, so try it on a folder containing ONLY a small subset of the documents before attempting to try it on a huge number of files. The following macro will extract any e-mail address in the documents and write them, one to a line, to a new document. It will not make any permanent changes to the documents themselves.

NOTE: IT WILL CRASH IF ANY OF THE DOCUMENTS ARE PASSWORD PROTECTED

http://www.gmayor.com/installing_macro.htm

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 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

End Sub