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