I have no doubt that the link opens the workbook, but in order to save the file locally using VBA, we would need to know the full path of the linked file as shown in the link so that the macro knows where to look for the named file. The following assumes that the full path is the hyperlink address and that it is readily accessible to the macro. If the target folder does not exist, the macro will create it in order to copy the file to it.
Option Explicit
Sub ProcessMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
CopyLinkedFile olMsg
lbl_Exit:
Exit Sub
End Sub
Sub CopyLinkedFile(olItem As Object)
Dim oLink As Object
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim FSO As Object
Dim strPath As String
Dim strFilename As String
Dim strDestinationPath As String
On Error GoTo ErrHandler
strDestinationPath = "Y:\BBG\Daily\" & Format(Date, "yyyy") & "\" & Format(Date, "m. mmmm")
CreateFolders strDestinationPath
If TypeName(olItem) = "MailItem" Then
With olItem
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
For Each oLink In oRng.Hyperlinks
If oLink.TextToDisplay Like "*.xlsx*" Then
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(oLink.Address) Then
strPath = oLink.Address
strFilename = Mid(strPath, InStrRev(strPath, "\"))
If FSO.FileExists(strDestinationPath & strFilename) Then
If Not FSO.GetFile(strDestinationPath & strFilename).Attributes And 1 Then
FSO.CopyFile strPath, strDestinationPath & strFilename, True
Else
FSO.GetFile(strFilename).Attributes = FSO.GetFile(strDestinationPath & strFilename).Attributes - 1
FSO.CopyFile strPath, strDestinationPath & strFilename, True
FSO.GetFile(strFilename).Attributes = FSO.GetFile(strDestinationPath & strFilename).Attributes + 1
End If
Else
FSO.CopyFile strPath, strDestinationPath & strFilename, True
End If
Else
MsgBox oLink.Address & " - not found"
End If
Exit For
End If
Next oLink
End With
End If
lbl_Exit:
Set FSO = Nothing
Set oLink = Nothing
Set oRng = Nothing
Set wdDoc = Nothing
Set olItem = Nothing
Exit Sub
ErrHandler:
Beep
Err.Clear
GoTo lbl_Exit
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lngPath = 3 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function