none
Outlook - VBA code to download email (Excel)attachment RRS feed

  • Question

  • Need VBA code for extracting excel attachment from my email with certain subject line and copy into my desktop as Samefilename in the email but at the end need email received date and time while saving in my desktop to identify the excel attachment as per date & time received .

    Please help me out

    
    Thursday, August 28, 2014 1:01 PM

Answers

  • You can run the first macro as a script from a rule that identifies the incoming messages. The second macro can be used to test the process or to save the attachments from a message already received.

    Sub SaveXLAttachment(olItem As MailItem)
    Const strPath As String = "C:\Path\"        'the path where the attachments are to be saved
    Const strFileType As String = "xlsx"        'The extension of the file type
    Dim olAttach As Attachment
        If 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
        End If
    End Sub

    Sub TestSaveXLAttachment()
    Dim olmsg As MailItem
        On Error Resume Next
        Set olmsg = ActiveExplorer.Selection.Item(1)
        SaveXLAttachment olmsg
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, August 28, 2014 1:25 PM
  • My original suggestion allowed messages to be processed as they arrive. If you want to process a folder full of messages then you just need to add the loop and conditions to the test macro part of my original code. This will give you the option to process messages you have received and automatically process future messages as they arrive by using a rule to run the script SaveXLAttachment.

    Sub TestSaveXLAttachments()
    Dim olmsg As Outlook.MailItem
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Const strSubject As String = "Daily Operations Custom All Req Statuses Report"
        On Error Resume Next
        Set olNS = GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        If Not olFolder Is Nothing Then
            For Each olmsg In olFolder.Items
                If olmsg.Class = olMail Then
                    If olmsg.Subject = strSubject Then
                        SaveXLAttachment olmsg
                    End If
                End If
                DoEvents
            Next olmsg
        End If
        MsgBox "Extraction complete"
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, August 29, 2014 5:21 AM

All replies

  • You can run the first macro as a script from a rule that identifies the incoming messages. The second macro can be used to test the process or to save the attachments from a message already received.

    Sub SaveXLAttachment(olItem As MailItem)
    Const strPath As String = "C:\Path\"        'the path where the attachments are to be saved
    Const strFileType As String = "xlsx"        'The extension of the file type
    Dim olAttach As Attachment
        If 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
        End If
    End Sub

    Sub TestSaveXLAttachment()
    Dim olmsg As MailItem
        On Error Resume Next
        Set olmsg = ActiveExplorer.Selection.Item(1)
        SaveXLAttachment olmsg
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, August 28, 2014 1:25 PM
  • 
     Public Sub Extract_Outlook_Email_Attachments()
      Dim OutlookOpened As Boolean
      Dim outApp As Outlook.Application
      Dim outNs As Outlook.NameSpace
      Dim outFolder As Outlook.MAPIFolder
      Dim outAttachment As Outlook.Attachment
      Dim outItem As Object
      Dim saveFolder As String
    
     
    
      Dim dateFormat
     dateFormat = Format(Now, "dd-mm-yyyy")
     saveFolder = "U:\My Documents"
      
    
        Dim outMailItem As Outlook.MailItem
        Dim inputDate As String, subjectFilter As String
       
    
         If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
    
         inputDate = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
         If inputDate = "" Then Exit Sub
    
         subjectFilter = ("Daily Operations Custom All Req Statuses Report")
    
         'Get or create Outlook object and make sure it exists before continuing
    
         OutlookOpened = False
         On Error Resume Next
         Set outApp = GetObject(, "Outlook.Application")
         If Err.Number <> 0 Then
             Set outApp = New Outlook.Application
             OutlookOpened = True
         End If
         On Error GoTo 0
    
         If outApp Is Nothing Then
             MsgBox "Cannot start Outlook.", vbExclamation
             Exit Sub
         End If
    
       Set outNs = outApp.GetNamespace("MAPI")
       Set outFolder = outNs.PickFolder
       'Set outFolder = outNs.Folders("Daily Ops custom")
       
    
         'Set outFolder = outNs.Folders("Daily Ops custom").Folders("Inbox")  'CHANGE FOLDER AS NEEDED
        'Set outFolder = outNs.PickFolder                                  'OR USER SELECTS FOLDER
    
         If Not outFolder Is Nothing Then
            For Each outItem In outFolder.Items
                If outItem.Class = Outlook.OlObjectClass.olMail Then
                    Set outMailItem = outItem
                     If outMailItem.Subject = subjectFilter Then
                         Debug.Print outMailItem.Subject
                         For Each outAttachment In outMailItem.Attachments
                      outAttachment.SaveAsFile saveFolder & outAttachment.FileName & strValues
                      
                      
              
                      Set outAttachment = Nothing
                      
                             
                         Next
                     End If
                 End If
             Next
         End If
    
         If OutlookOpened Then outApp.Quit
    
         Set outApp = Nothing
    
       End Sub
      Public Sub Extract_Outlook_Email_Attachments()
      Dim OutlookOpened As Boolean
      Dim outApp As Outlook.Application
      Dim outNs As Outlook.NameSpace
      Dim outFolder As Outlook.MAPIFolder
      Dim outAttachment As Outlook.Attachment
      Dim outItem As Object
      Dim saveFolder As String
    
    
     saveFolder = "U:\My Documents"
      
    
        Dim outMailItem As Outlook.MailItem
        Dim inputDate As String, subjectFilter As String
       
    
         If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
    
         inputDate = InputBox("Enter date to filter the email subject", "Extract Outlook email attachments")
         If inputDate = "" Then Exit Sub
    
         subjectFilter = ("Daily Operations Custom All Req Statuses Report")
    
    
         OutlookOpened = False
         On Error Resume Next
         Set outApp = GetObject(, "Outlook.Application")
         If Err.Number <> 0 Then
             Set outApp = New Outlook.Application
             OutlookOpened = True
         End If
         On Error GoTo 0
    
         If outApp Is Nothing Then
             MsgBox "Cannot start Outlook.", vbExclamation
             Exit Sub
         End If
    
       Set outNs = outApp.GetNamespace("MAPI")
       Set outFolder = outNs.PickFolder
                                    
    
         If Not outFolder Is Nothing Then
            For Each outItem In outFolder.Items
                If outItem.Class = Outlook.OlObjectClass.olMail Then
                    Set outMailItem = outItem
                     If outMailItem.Subject = subjectFilter Then
                         Debug.Print outMailItem.Subject
                         For Each outAttachment In outMailItem.Attachments
                      outAttachment.SaveAsFile saveFolder & outAttachment.FileName
                    
            
                      Set outAttachment = Nothing
                      
                             
                         Next
                     End If
                 End If
             Next
         End If
    
         If OutlookOpened Then outApp.Quit
    
         Set outApp = Nothing
    
       End Sub
      
    
    
    
    
    
    
    
    

    Hello i got the above code and its working fine can u pls only add code to save the file as Daily operations custom All Req Statuses Report with date and time received of the email. since i get the email of same subject daily from a common mail box. I want to identify them by date.
    
    Thursday, August 28, 2014 1:57 PM
  • My original suggestion allowed messages to be processed as they arrive. If you want to process a folder full of messages then you just need to add the loop and conditions to the test macro part of my original code. This will give you the option to process messages you have received and automatically process future messages as they arrive by using a rule to run the script SaveXLAttachment.

    Sub TestSaveXLAttachments()
    Dim olmsg As Outlook.MailItem
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Const strSubject As String = "Daily Operations Custom All Req Statuses Report"
        On Error Resume Next
        Set olNS = GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        If Not olFolder Is Nothing Then
            For Each olmsg In olFolder.Items
                If olmsg.Class = olMail Then
                    If olmsg.Subject = strSubject Then
                        SaveXLAttachment olmsg
                    End If
                End If
                DoEvents
            Next olmsg
        End If
        MsgBox "Extraction complete"
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, August 29, 2014 5:21 AM
  • If you 'll a problem to look into attachments of attach MSG CC item, look to this solution: Jak dostać listę załączników oraz załączników osadzonych w plikach MSG

    Oskar Shon, Office System MVP - www.VBATools.pl
    if Helpful; Answer when a problem solved

    Monday, September 1, 2014 7:06 AM
    Answerer
  • If you 'll a problem to look into attachments of attach MSG CC item, look to this solution: Jak dostać listę załączników oraz załączników osadzonych w plikach MSG

    Oskar Shon, Office System MVP - www.VBATools.pl
    if Helpful; Answer when a problem solved

    Hi Oskar,

    The link you provided did not work for me.

    Maybe you can post the correct link.

    Thanks,

    Daniel


    Daniel van den Berg | Washington, USA | "Anticipate the difficult by managing the easy"

    Please vote an answer helpful if they helped. Please mark an answer(s) as an answer when your question is being answered.

    Friday, September 19, 2014 5:20 AM
    Moderator
  • The 2nd part of this code works fine except that the input date doesn't matter and my macros saves ALL attachments titled with the subject. 
    Wednesday, September 20, 2017 4:01 PM