无论如何要将电子邮件导出到包含附件的文件夹？ [英] Anyway To Export Email To Folder Including Attachments?

问题描述

我有一个系统，我已经创建了超时，将电子邮件数据放到Excel电子表格中。这很棒，但是在运行之后我还想做的事情是将包括Outlook中任何附件的电子邮件提取到我的Windows PC上的新文件夹中。

当电子邮件在Excel电子表格上，然后电子邮件和附件被提取到我的PC上的文件夹
时，我想要添加一个唯一的ID（可能是电子邮件的日期，或者只是一个随机数）到电子邮件，然后电子邮件会自动将链接地址发送回已提取的电子邮件旁边的电子表格，并将唯一ID添加到
电子表格中。听起来有点混乱，我希望这有意义（这可能吗？）

人们将回复电子邮件，我也希望回复电子邮件到原始邮件（如果
具有上面列出的唯一ID，则使用与原始电子邮件相同的ID。再次抱歉，如果这听起来有点令人困惑，很高兴在需要时详细介绍。

这类新东西的种类，所以任何帮助都会很棒。 

这是我到目前为止编写的代码;

Here is the code I have written so far;

推荐答案

您不需要对Outlook的引用，但您确实需要创建或打开Outlook实例。以下将将消息保存在指示的路径中（如果不存在，将创建它）c / w任何附件。我会警告不要在工作表中放置消息
正文，因为它们可能非常大并且包含可能存在问题的图形。宏（在个人工作簿中）使用几个函数来确保不会覆盖碰巧具有相同名称的消息。我认为
你应该可以使用它。

You don't need a reference to Outlook, but you do need to create or open an Outlook instance. The following will save the messages in the path indicated (which it will create if not present) c/w any attachments. I would caution against putting the message bodies in the worksheet as they can be very large and include graphics which are likely to be an issue. The macro (in the Personal workbook) uses a couple of functions to ensure that messages that happen to have the same names are not overwritten. I think you should be able to work with this.

Option Explicit
Const fPath As String = "C:\Path\Reports\" 'The path to save the messages

Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
    Set xlBook = Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    With xlSheet
        .Cells(1, 1) = "Sender"
        .Cells(1, 2) = "Subject"
        .Cells(1, 3) = "Date"
        '.Cells(1, 4) = "Size"
        .Cells(1, 5) = "EmailID"
        .Cells(1, 6) = "Body"
        CreateFolders fPath
        Set olNS = olApp.GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        For Each olItem In olFolder.Items
            NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            If olItem.Class = 43 Then
                .Cells(NextRow, 1) = olItem.Sender
                .Cells(NextRow, 2) = olItem.Subject
                .Cells(NextRow, 3) = olItem.SentOn
                '.Cells(NextRow, 4) =
                .Cells(NextRow, 5) = SaveMessage(olItem)
                '.Cells(NextRow, 6) = olItem.Body 'Are you sure?
            End If
        Next olItem
    End With
     MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
    Set olApp = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub

Function SaveMessage(olItem As Object) As String
Dim Fname As String
    Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
    Fname = Replace(Fname, Chr(58) & Chr(41), "")
    Fname = Replace(Fname, Chr(58) & Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")
    SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
    SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function

Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For iPath = 1 To UBound(vPath)
        strPath = strPath & vPath(iPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next iPath
End Sub

Private Function FolderExists(ByVal PathName As String) As Boolean
   Dim nAttr As Long
   On Error GoTo NoFolder
   nAttr = GetAttr(PathName)
   If (nAttr And vbDirectory) = vbDirectory Then
      FolderExists = True
   End If
NoFolder:
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

这篇关于无论如何要将电子邮件导出到包含附件的文件夹？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！