Download attachment (attachment not found)

Question

I've got a code from here and I'm tweaking it for my need. My need is quite simple: I need it to download if it has the name of the Daily Tracker I'm keeping track of (as it changes daily with the Format(Now)). The problem is that it is not finding the attachment.

The code can find the email if I substitute the ElseIf to Next part for oOlItm.Display, but won't download the attachment.

Sub AttachmentDownload()

Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"

    Dim oOlAp As Object
    Dim oOlns As Object
    Dim oOlInb As Object
    Dim oOlItm As Object
    Dim oOlAtch As Object

    Dim NewFileName As String
    NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy")

    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)


    For Each oOlItm In oOlInb.Items
        If InStr(oOlItm.Subject, NewFilename)) <> 0 Then
            ElseIf oOlItm.Attachments.Count <> 0 Then
                For Each oOlAtch In oOlItm.Attachments
                    oOlAtch.SaveAsFile (AttachmentPath)
                    Exit For
                Next
            Else
                MsgBox "No attachments found"
            End If
            Exit For
        Next
End Sub

The email:

Answer 1

This should work for you:

   Sub AttachmentDownload()

Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"

    Dim oOlAp As Object
    Dim oOlns As Object
    Dim oOlInb As Object
    Dim oOlItm As Object
    Dim oOlAtch As Object
    Dim oOlResults As Object

    Dim x As Long

    Dim NewFileName As String
    NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")

    'You can only have a single instance of Outlook, so if it's already open
    'this will be the same as GetObject, otherwise it will open Outlook.
    Set oOlAp = CreateObject("Outlook.Application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

    'No point searching the whole Inbox - just since yesterday.
    Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")

    'If you have more than a single attachment they'll all overwrite each other.
    'x will update the filename.
    x = 1
    For Each oOlItm In oOlResults
        If oOlItm.attachments.Count > 0 Then
            For Each oOlAtch In oOlItm.attachments
                If GetExt(oOlAtch.FileName) = "xlsx" Then
                    oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx"
                End If
                x = x + 1
            Next oOlAtch
        End If
    Next oOlItm

End Sub

'----------------------------------------------------------------------
' GetExt
'
'   Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String

    Dim mFSO As Object
    Set mFSO = CreateObject("Scripting.FileSystemObject")

    GetExt = mFSO.GetExtensionName(FileName)
End Function

Another way of doing it is from within Outlook:

Create a new folder in your Outlook Inbox and set a rule to move the email to this folder when it arrives. You can then write code to watch this folder and save the file as soon as it arrives.

Place this code within the ThisOutlookSession module in Outlook.

Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\TEMP\TestExcel\"

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace

    Set ns = Application.GetNamespace("MAPI")
    Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _
                              .Folders.Item("Inbox") _
                              .Folders.Item("My Email For Processing").Items

End Sub

Sub TargetFolderItems_ItemAdd(ByVal Item As Object)

     'when a new item is added to our "watched folder" we can process it
    Dim olAtt As Attachment
    Dim i As Integer

    Dim sTmpFileName As String

    Dim objFSO As Object
    Dim sExt As String

    If Item.Attachments.Count > 0 Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        For i = 1 To Item.Attachments.Count
            Set olAtt = Item.Attachments(i)

            sExt = objFSO.GetExtensionName(olAtt.FileName)

            If sExt = "xlsx" Then
                sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx"
            End If

            Item.UnRead = False
            olAtt.SaveAsFile FILE_PATH & sTmpFileName
            DoEvents

        Next
    End If
    Set olAtt = Nothing

    MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker"

End Sub

Private Sub Application_Quit()

    Dim ns As Outlook.NameSpace
    Set TargetFolderItems = Nothing
    Set ns = Nothing

End Sub

Create a new module in Outlook and put this code in there. This will create a messagebox that won't stop whatever you're doing.

Public Function MsgPopup(Optional Prompt As String, _
                         Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
                         Optional Title As String, _
                         Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter
' to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT ‘cancel’ or the default button choice.

' Nigel Heffernan, 2006. This code is in the public domain.

' Uses late-binding: bad for performance and stability, useful for code portability
' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell

    Dim objWshell As Object
    Set objWshell = CreateObject("WScript.Shell")

    MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)

    Set objWshell = Nothing

End Function