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!