自动从电子邮件下载附件并将其保存到 Excel

Question

目前我下面列出的代码将从传入的电子邮件中复制正文信息并打开指定的 Excel 工作表并将内容复制到 Excel 工作表上并关闭它。 我还想将收到的电子邮件中的附件保存到此指定路径：C:\\Users\\ltorres\\Desktop\\Projects

我已经试过了，但是这段代码不会与 Outlook 合并。 我必须用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

Answer 1

要添加到@Om3r 响应，您可以将此代码（未经测试）添加到ThisOutlookSession模块：

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

这将监视 Lighting Emails 文件夹（或您选择的任何文件夹）并在电子邮件到达该文件夹时执行SaveAtmt_ExportToExcel程序。

这意味着 Excel 将针对每封电子邮件打开和关闭。 它还会中断您正在执行的任何其他操作以打开 Excel 并执行 - 因此可能想要更新以便它只打开 Excel 一次并运行 Outlook 规则以每天一次而不是始终打开电子邮件将电子邮件放置在正确的文件夹中。

Answer 2

试试这个方法...

更新SaveFolder = "c:\\temp\\"和Workbooks.Open("C:\\Temp\\Book1.xlsx")

在 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