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

问题描述

限时删除！！

目前，我下面列出的代码将从收到的电子邮件中复制身体信息，并打开指定的Excel表，并将内容复制到Excel表上并将其关闭。我也想保存收到的电子邮件的附件到这个指定的路径：C：\Users\ltorres\Desktop\Projects

我已经尝试了，但是这段代码不会与前景一致。我将不得不使用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（现在，yyyy-mm-dd H-mm）
 
对于每个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变量
 Dim oXLApp As Object，oXLwb As Object，oXLws As Object 
 Dim lRow As Long 
 
 strID = MyMail.EntryID 
设置olNS = Application.GetNamespace（ MAPI）
设置olMail = olNS.GetItemFromID（strID）
 
'~~>建立一个EXCEL应用程序对象
 On Error Resume Next 
设置oXLApp = GetObject（，Excel.Application）
 
'~~>如果没有找到，则创建新的实例
如果Err.Number<> 0然后
设置oXLApp = CreateObject（Excel.Application）
结束如果
 Err.Clear 
错误GoTo 0 
 
'~~> ;显示Excel 
 oXLApp.Visible = True 
 
'~~>打开相关文件
设置oXLwb = oXLApp.Workbooks.Open（C：\Users\ltorres\Desktop\Projects\Project 2\TemplateFinal\lightlight.xlsm）
 
'~~>设置相关的输出表。根据需要更改
设置oXLws = oXLwb.Sheets（Multiplier）
 
 lRow = oXLws.Range（A& oXLws.Rows.Count）.End（xlUp）.Row + 1 
 
'~~>写入outlook 
与oXLws 
 lRow = .Range（A& .Rows.Count）.End（xlUp）.Row + 1 
 Dim MyAr（）As String 
 MyAr = Split（olMail.Body，vbCrLf）
对于i = LBound（MyAr）到UBound（MyAr）
 .Range（A& lRow）.Value = MyAr（i）
 lRow = lRow + 1 
 Next i 
'
结束
 
'~~>关闭并清理Excel 
 oXLwb.Close（True）
 oXLApp.Quit 
设置oXLws = Nothing 
设置oXLwb = Nothing 
设置oXLApp = Nothing 
 
设置olMail = Nothing 
设置olNS = Nothing 
 End Sub 
  

解决方案

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

 私有WithEvents objNewMailItems作为Outlook.Items 
 Dim WithEvents TargetFolderItems作为项目
 
私人子应用程序_Startup（）
 
 Dim ns As Outlook.NameSpace 
 
设置ns = Application.GetNamespace（MAPI）
'更新到正确的Outlook文件夹。 
设置TargetFolderItems = ns.Folders.item（邮箱 - 路易斯）_ 
 .Folders.item（收件箱）_ 
 .Folders.item（照明电子邮件）项目
 
 End Sub 
 
 Sub TargetFolderItems_ItemAdd（ByVal item As Object）
 SaveAtmt_ExportToExcel项
 End Sub 
  / pre> 
 
 
这将会观看照明电子邮件文件夹（或任何您选择的文件夹），并执行 SaveAtmt_ExportToExcel 电子邮件到达该文件夹。 
 
 
 
这将意味着Excel会为每个电子邮件打开和关闭。它也将中断您正在做的任何打开Excel并执行的任何操作 - 所以可能需要更新，因此它只能打开一次Excel，并运行Outlook规则将电子邮件放置在正确的文件夹中，而不是始终处于打开状态。 
 
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
 解决方案 
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.
                        
这篇关于从电子邮件自动下载并保存附件到Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！
                        
1403页，肝出来的..