将附件从邮件自动下载并保存到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

试试这样...

更新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 

Answer 2

要添加到@ 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 

这会让看表的照明电子邮件文件夹（或其他文件夹您选择），并在电子邮件到达该文件夹时执行SaveAtmt_ExportToExcel过程。

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