CODEWITHSUNDEEP
excelvba
NeedHelpmonkey
NeedHelpmonkey

Reputation: 15

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

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

Upvotes: 0

Views: 407

Answers (1)

Seiya Su
Seiya Su

Reputation: 1874

This is possible. Iterate the inbox and then get every MailItem. If the MailItem.HTMLBody contains the xls name(X_Y_Daily_2018-08-21-08-40-45.xlsx), use Regex to get the URL then download the file from the url by VBA(Like this):

Just some init code but not the final:

Sub TestOutlook()
    Dim olApp As Outlook.Application, olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, Item As Outlook.MailItem
    Dim eFolder As Outlook.Folder '~~> additional declaration
    Dim i As Long
    Dim x As Date, ws As Worksheet '~~> declare WS variable instead
    Dim lrow As Long '~~> additional declaration
    Dim MessageInfo
    Dim Result
    Set ws = ActiveSheet '~~> or you can be more explicit using the next line
    'Set ws = Thisworkbook.Sheets("YourTargetSheet")
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    x = Date

    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
        'Debug.Print eFolder.Name
        Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
        For i = olFolder.Items.Count To 1 Step -1
            If TypeOf olFolder.Items(i) Is MailItem Then
                Set Item = olFolder.Items(i)
                'MsgBox Item.Body
                'filter (Item)
                'If InStr(Item.Subject, "Test download") > 0 Then
                   ' MsgBox "Here"
                   '                     MessageInfo = "" & _
                    '        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
                    '        "Sent : " & Item.SentOn & vbCrLf & _
                    '        "Received : " & Item.ReceivedTime & vbCrLf & _
                    '        "Subject : " & Item.Subject & vbCrLf & _
                    '        "Size : " & Item.Size & vbCrLf & _
                     '       "Message Body : " & vbCrLf & Item.Body
                     '   Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
               ' End If
            End If
        Next i
        Set olFolder = Nothing
    Next eFolder
End Sub

Sub filter(Item As Outlook.MailItem)
    Dim ns As Outlook.Namespace
    Dim MailDest As Outlook.Folder
    Set ns = Application.GetNamespace("MAPI")
    Set Reg1 = CreateObject("VBScript.RegExp")
    Reg1.Global = True
    Reg1.Pattern = "(.*Test download.*)"
    If Reg1.test(Item.Subject) Then
        'Set MailDest = ns.Folders("Personal Folders").Folders("one").Folders("a")
        'Item.Move MailDest
        MsgBox Item.Body
    End If
End Sub

Upvotes: 0

Related Questions