none
How to download attachment from the latest email with specific subject and from? RRS feed

  • Question

  • I want to download the attachment from the latest email with subject containing 'Sample Subject' and from 'me@xyz.com'

    I get several emails per day matching this criteria. I want to download the attachment only from the latest email.

    Can someone help me with the sample snippet?

    Thanks!


    Thursday, April 4, 2013 4:24 AM

Answers

  • By 'download' can we assume that you mean 'save', as the attachment(s) would be downloaded with the message.

    Snippet?  The following should do what you want. It will prompt you for the folder location to save the files and the folder containing the messages. You can avoid these dialogs if you always use the same locations. The filenames of the saved attachments include the date to avoid overwriting any existing file of the same name. If that is not important you can remove the date bit.

    Sub SaveAttachments()
    'macro requires Shell32.dll to be present and registered in Windows
    Dim strPath As String
    Dim SH As Object
    Dim Fldr As Object
    Dim olFolder As Folder
    Dim olItem As MailItem
    Dim olAttach As Attachment
    Dim i As Long

    Const strSubject As String = "Sample Subject"
    Const strSender As String = "me@xyz.com"
    Const strFileType As String = "dotm"        'extension of attachment file type


        Set SH = New Shell32.Shell
        Set Fldr = SH.BrowseForFolder(0, "Select the folder to store the attachments", &H400)
        On Error GoTo Err_Handler
        If Not Fldr Is Nothing Then
            If Right$(Fldr.Items.Item.Path, 1) <> "\" Then
                strPath = Fldr.Items.Item.Path & "\"
            End If
    Err_ReEntry:
            Set olFolder = Application.Session.PickFolder
            olFolder.Items.Sort "[Received]", True
            For i = 1 To olFolder.Items.Count
                Set olItem = olFolder.Items(i)
                If InStr(1, LCase(olItem.Subject), LCase(strSubject)) > 0 And _
                   olItem.SenderEmailAddress = strSender And _
                   olItem.Attachments.Count > 0 Then
                    For Each olAttach In olItem.Attachments
                        If Right(LCase(olAttach.FileName), Len(strFileType)) = strFileType Then
                            olAttach.SaveAsFile _
                                    strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                                            Chr(32) & olAttach.FileName
                        End If
                    Next olAttach
                    Exit For
                End If
            Next i
        End If
        Set Fldr = Nothing
        Set SH = Nothing
        Set olFolder = Nothing
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    Err_Handler:
        If Err.Number = 91 Then
            If Fldr.Title = "Desktop" Then
                strPath = Fldr.Items.Item(1).Path & "\Desktop\"
                Resume Err_ReEntry
            End If
        End If
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, April 4, 2013 11:26 AM

All replies

  • Hi

    Please have a look at the following code to save the Attachments

    http://www.rondebruin.nl/mail/folder2/saveatt.htm

    you can use the NewMail event to monitor the mails and then call the code to Save attachment

    http://support.microsoft.com/kb/895940?wa=wsignin1.0

    Cheers

    Shasur


    http://www.vbadud.blogspot.com http://www.dotnetdud.blogspot.com

    Thursday, April 4, 2013 7:35 AM
  • Thanks for the reply Shasur!

    I do not want to monitor the mailbox.

    I want to download attachment from the latest email whenever I run the script

    Thursday, April 4, 2013 8:12 AM
  • By 'download' can we assume that you mean 'save', as the attachment(s) would be downloaded with the message.

    Snippet?  The following should do what you want. It will prompt you for the folder location to save the files and the folder containing the messages. You can avoid these dialogs if you always use the same locations. The filenames of the saved attachments include the date to avoid overwriting any existing file of the same name. If that is not important you can remove the date bit.

    Sub SaveAttachments()
    'macro requires Shell32.dll to be present and registered in Windows
    Dim strPath As String
    Dim SH As Object
    Dim Fldr As Object
    Dim olFolder As Folder
    Dim olItem As MailItem
    Dim olAttach As Attachment
    Dim i As Long

    Const strSubject As String = "Sample Subject"
    Const strSender As String = "me@xyz.com"
    Const strFileType As String = "dotm"        'extension of attachment file type


        Set SH = New Shell32.Shell
        Set Fldr = SH.BrowseForFolder(0, "Select the folder to store the attachments", &H400)
        On Error GoTo Err_Handler
        If Not Fldr Is Nothing Then
            If Right$(Fldr.Items.Item.Path, 1) <> "\" Then
                strPath = Fldr.Items.Item.Path & "\"
            End If
    Err_ReEntry:
            Set olFolder = Application.Session.PickFolder
            olFolder.Items.Sort "[Received]", True
            For i = 1 To olFolder.Items.Count
                Set olItem = olFolder.Items(i)
                If InStr(1, LCase(olItem.Subject), LCase(strSubject)) > 0 And _
                   olItem.SenderEmailAddress = strSender And _
                   olItem.Attachments.Count > 0 Then
                    For Each olAttach In olItem.Attachments
                        If Right(LCase(olAttach.FileName), Len(strFileType)) = strFileType Then
                            olAttach.SaveAsFile _
                                    strPath & Format(olItem.ReceivedTime, "yyyymmdd-HHMMSS") & _
                                            Chr(32) & olAttach.FileName
                        End If
                    Next olAttach
                    Exit For
                End If
            Next i
        End If
        Set Fldr = Nothing
        Set SH = Nothing
        Set olFolder = Nothing
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    Err_Handler:
        If Err.Number = 91 Then
            If Fldr.Title = "Desktop" Then
                strPath = Fldr.Items.Item(1).Path & "\Desktop\"
                Resume Err_ReEntry
            End If
        End If
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, April 4, 2013 11:26 AM
  • Thanks Graham!

    But the code snippet on my Laptop throwing an error with types Folder, MailItem, Attachment & 'Set SH = New Shell32.Shell' though my system has Shell32.dll

    Thanks

    Srini

    Thursday, April 4, 2013 12:15 PM
  • Set a reference to the Microsoft Shell Controls and Automation object library in VBA Tools > References

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, April 4, 2013 1:12 PM