Outlook VBA: Save a file from a link in outlook to a specific folder on my computer

[needhelpalwa]

I get a report everyday in the form on a link (for an excel file) something like-

<<\X_Y_Daily_2018-08-21-08-40-45.xlsx>>

which I would like to save on my desktop in a specific folder in outlook after renaming.I am very new to VBA and hunted for something like this but to no avail.
I already have a rule to save all these emails to a specific folder called "Daily Track". Please let me know whether this is possible, really would appreciate all help to make me feel less like a data saver all day... :)


I want to save the file to Y:\BBG\Daily\2018\8. August

[gmayor]

Where does the link, link to?

[needhelpalwa]

If I click the link, it opens the excel directly.

The excel's location is in a shared drive folder of my firm.

[gmayor]

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

[needhelpalwa]

You can't tell how grateful I am for this, thanks a lot! This makes my life 80% simpler, you are awesome!!!

[gmayor]

Glad to hear it worked, given that the details about the link were sketchy. You can make your life simpler still if you run the main macro - CopyLinkedFile - as a script from a rule that will process the messages automatically as they arrive - though be aware that the macro, as it stands, will overwrite any previous file of the same name.

[colinp]

Thanks. It works. This makes things much easier!