从电子邮件下载并保存附件到Excel

目前我下面列出的代码将从收到的电子邮件中复制正文信息并打开指定的Excel表格，并将内容复制到Excel表格中并closures它。 我还想将传入邮件中的附件保存到指定的path：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响应，您可以将此代码（未经testing）添加到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 

这将观看照明邮件文件夹（或任何您select的文件夹），并执行SaveAtmt_ExportToExcel程序，只要电子邮件到达该文件夹。

这将意味着Excel将打开和closures每个电子邮件。 它也会中断你打开Excel和执行的任何操作 – 所以可能需要更新，所以它只打开一次Excel，并运行Outlook规则将电子邮件放置在正确的文件夹中，而不是每天一次。

Answer 2

试试这个方法…

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

在Outlook 2010上testing

 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