add a second criteria to text extraction from documents macro

good day experts,

I have a word macro which goes into each document with a windows folder, grabs the email addresses in that folder, and then adds that email address to a list in a new document.

I need it to do that ASWELL as include the filename from the document that email address was extracted from next to the email address after a coma

the VB Code is attached: Please Help me.

Welcome to the forum

Please take a minute and read the FAQs at the link in my sig

I didn't test, but it seems you could just add the marked line

You could also include the macro in a docm file to upload

Code:

---

Option Explicit


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 & ", " & strPath & strFilename & 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

---