How can you have reserved characters in the filenames?
The following will copy accessible linked files to the folder on your desktop, with the original filenames. If the name already exists in the target folder it will be overwritten. If you want to retain existing files then see the filenameunique code example on my web site. The target folder is created if it doesn't exist. Select a message and Run the Test macro. Alternatively you could run the main macro as a script from a rule that identifies the messages in question as they arrive.
Option Explicit
Sub Test()
Dim olMsg As MailItem
'On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveLinkedFiles olMsg
lbl_Exit:
Exit Sub
End Sub
Sub SaveLinkedFiles(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 18 Jun 2018
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oLink As Object
Dim strSource As String
Dim strFname As String
Dim fso As Object
CreateFolders Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks"
Set fso = CreateObject("Scripting.FileSystemObject")
If TypeName(olItem) = "MailItem" Then
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
.Display
For Each oLink In wdDoc.Hyperlinks
strSource = oLink.Address
If fso.FileExists(strSource) Then
strFname = Mid(strSource, InStrRev(strSource, Chr(92)))
FileCopy oLink.Address, Environ("USERPROFILE") & "\Desktop\Outlook Hyperlinks" & strFname
End If
Next oLink
End With
End If
olItem.Close 0
lbl_Exit:
Set olInsp = Nothing
Set fso = Nothing
Set wdDoc = Nothing
Set oLink = Nothing
Exit Sub
End Sub
Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.CreateFolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub