將附件從郵件自動下載並保存到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規則將電子郵件每天一次放在正確的文件夾中，而不是始終打開。