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

以这种方式试试......

更新repo.Data.GroupBy(d => d.SomeNumber??(object)d.SomeString); 和 SaveFolder = "c:\temp\"

在Outlook 2010上测试

Workbooks.Open("C:\Temp\Book1.xlsx")

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

2 个答案: