add a second criteria to text extraction from documents macro

[clintonp1976]

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.

[Paul_Hossler]

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





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