Download and Save Attachment from Email Automatically to Excel

问题

Currently my code listed below will copy body information from an incoming email and open the designated excel sheet and copy the contents onto the excel sheet and close it. I would also like to save attachments from incoming email to this designated path :C:\Users\ltorres\Desktop\Projects

I have tried this, but this code will not incorporate with outlook. I would have to run it with excel

---

Public Sub saveAttachtoDisk (itm As Outlook.MailItem) 
    Dim objAtt As Outlook.Attachment 
    Dim saveFolder As String
    Dim dateFormat As String
    saveFolder = "C:\Users\ltorres\Desktop\Projects"
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")

    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
        Set objAtt = Nothing
    Next 
End Sub

---

Const xlUp As Long = -4162

Sub ExportToExcel(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String

    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Show Excel
    oXLApp.Visible = True

    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\Users\ltorres\Desktop\Projects\Project 2\TemplateFinal\lighting.xlsm")

    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Multiplier")

    lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1

    '~~> Write to outlook
                        With oXLws
                    lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                    Dim MyAr() As String
                    MyAr = Split(olMail.Body, vbCrLf)
                    For i = LBound(MyAr) To UBound(MyAr)
                        .Range("A" & lRow).Value = MyAr(i)
                        lRow = lRow + 1
                    Next i
                            '
                        End With

    '~~> Close and Clean up Excel
    oXLwb.Close (True)
    oXLApp.Quit
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing

    Set olMail = Nothing
    Set olNS = Nothing
End Sub

回答1:

To add to @Om3r response, you could add this code (untested) to the ThisOutlookSession module:

Private WithEvents objNewMailItems As Outlook.Items
Dim WithEvents TargetFolderItems As Items

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace

    Set ns = Application.GetNamespace("MAPI")
    'Update to the correct Outlook folder.
    Set TargetFolderItems = ns.Folders.item("Mailbox - Luis") _
                              .Folders.item("Inbox") _
                              .Folders.item("Lighting Emails").Items

End Sub

Sub TargetFolderItems_ItemAdd(ByVal item As Object)
    SaveAtmt_ExportToExcel item
End Sub

This will watch the Lighting Emails folder (or whatever folder you choose) and execute the SaveAtmt_ExportToExcel procedure whenever an email arrives in that folder.

This will mean that Excel will open and close for each email. It will also interrupt whatever else you're doing to open Excel and execute - so will probably want to update so it only opens Excel once and to run the Outlook rule to place the emails in the correct folder once a day rather than always on.

回答2:

Try it this way...

Update SaveFolder = "c:\temp\" and Workbooks.Open("C:\Temp\Book1.xlsx")

Tested on Outlook 2010

Public Sub SaveAtmt_ExportToExcel(Item As Outlook.MailItem)
    Dim Atmt As Outlook.Attachment
    Dim SaveFolder As String
    Dim DateFormat As String

    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String

    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long
    Dim i As Long

    SaveFolder = "c:\temp\"
    DateFormat = Format(Now, "yyyy-mm-dd H mm")

    For Each Atmt In Item.Attachments
        Atmt.SaveAsFile SaveFolder & "\" & DateFormat & " " & Atmt.DisplayName
    Next


    strID = Item.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Show Excel
    oXLApp.Visible = True

    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("C:\Temp\Book1.xlsx")

    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Multiplier")

    lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1

    '~~> Write to outlook
    With oXLws

        lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1

        Dim MyAr() As String

        MyAr = Split(olMail.body, vbCrLf)

        For i = LBound(MyAr) To UBound(MyAr)
            .Range("A" & lRow).Value = MyAr(i)
            lRow = lRow + 1
        Next i
        '
    End With

    '~~> Close and Clean
    oXLwb.Close (True)
    oXLApp.Quit

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Set Atmt = Nothing
End Sub

来源：https://stackoverflow.com/questions/37355580/download-and-save-attachment-from-email-automatically-to-excel