![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 and Office | Word | For home | Windows
A family of Microsoft word processing software products for creating web, email, and print documents.
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
