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

As this is a very old thread, it needs an update. I would recommend using http://www.gmayor.com/document_batch_processes.htm to deal with the file handling and the error correction, using the following custom process to extract e-mail data from either the current document or a batch of documents.

Function ExtractEMailAddress(oDoc As Document) As Boolean

Dim oNewDoc As Document

Dim hLink As Hyperlink

Dim bFound As Boolean

    On Error GoTo Err_Handler

    For Each oNewDoc In Documents

        If oNewDoc.name = "EmailList.docx" Then

            bFound = True

            Exit For

        End If

    Next oNewDoc

    If Not bFound Then

        Set oNewDoc = Documents.Add

        oNewDoc.SaveAs2 "EmailList.docx"

    End If

    Options.AutoFormatReplaceHyperlinks = True

    oDoc.Range.AutoFormat

    For Each hLink In oDoc.Hyperlinks

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

            oNewDoc.Range.InsertAfter Replace(hLink.Address, "mailto:", "") & vbCr

        End If

    Next hLink

    ExtractEMailAddress = True

lbl_Exit:

    Exit Function

Err_Handler:

    ExtractEMailAddress = False

    Resume lbl_Exit

End Function

With regard to getting the name associated with the hyperlink, If the following doesn't work for you I would need to see an example. Names can be extraordinarily complex and may not fit the criteria of 'the first two words'. Furthermore whatever you may think of as a 'word' the application may not agree. However the following variation will include the first two words of the paragraph.

Function ExtractEMailAddress(oDoc As Document) As Boolean

Dim oNewDoc As Document

Dim strText As String

Dim hLink As Hyperlink

Dim bFound As Boolean

    On Error GoTo Err_Handler

    For Each oNewDoc In Documents

        If oNewDoc.name = "EmailList.docx" Then

            bFound = True

            Exit For

        End If

    Next oNewDoc

    If Not bFound Then

        Set oNewDoc = Documents.Add

        oNewDoc.SaveAs2 "EmailList.docx"

    End If

    Options.AutoFormatReplaceHyperlinks = True

    oDoc.Range.AutoFormat

    For Each hLink In oDoc.Hyperlinks

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

            strText = hLink.Range.Paragraphs(1).Range.Words(1) & _

hLink.Range.Paragraphs(1).Range.Words(2) & "- " & _

Replace(hLink.Address, "mailto:", "") & vbCr

            oNewDoc.Range.InsertAfter strText

        End If

    Next hLink

    ExtractEMailAddress = True

lbl_Exit:

    Exit Function

Err_Handler:

    ExtractEMailAddress = False

    Resume lbl_Exit

End Function

Try the following modification of Graham's code:

 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

 Dim rng As Range

 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

            Set rng = hLink.Range.Paragraphs(1).Range

            rng.Collapse wdCollapseStart

            rng.MoveEnd wdWord, 2

             oNewDoc.Range.InsertAfter rng.Text & " - " & 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

Thank you so much all - especially Graham & Doug,

You are right it is complex since it is not necessarily the first 2 words but it will aelast et the bulk of names ....

John J Doe (PhD; Assoc Prof); Primate evolution ecology, conservation biology, tropical forest ecology, vertebrate-plant

interactions; ******@gfbsd.com

Betty Johnson (PhD 2001; Assoc Prof); Cu evolution, cultural transmission, behavioral ecology, evolutionary theory; E •; ******@gfbsd.com

Teste Names (PhD U 1997; Assoc Prof); Environmental confli( cultural politics of neoliberalism, petropolitics, biopolitics; ******@gfbsd.com

Google A Facebook (PhD 1980; Prof); Discours analysis, sociolinguistics, language and culture, language and gender/sexuali text; ******@gfbsd.com

this is how the data appears mostly....but thanks anyway so much its a good start for me ..didnt realise the hlink could be extended to read the words in the paragraph as well...:)

If you want to get the qualifications and the titles, such as (PhD: Assoc Prof),

Use

            With rng

                .Collapse wdCollapseStart

                .MoveEndUntil Cset:=")", count:=wdForward

                .MoveRight Unit:=wdCharacter, count:=1, Extend:=wdExtend

            End With

in place of

              rng.Collapse wdCollapseStart

              rng.MoveEnd wdWord, 2

If you don't want the qualifications and the titles, use just

            With rng

                .Collapse wdCollapseStart

                .MoveEndUntil Cset:="(", count:=wdForward

             End With