尝试从 Outlook 存档电子邮件文件

Posted 2023-02-23

【中文标题】尝试从 Outlook 存档电子邮件文件

【英文标题】：Attempting to archive email files from Outlook

【发布时间】：2018-07-24 09:01:15

【问题描述】：

我们正在尝试减少 Outlook PSTs 的大小，方法是在项目完成后将不再相关的电子邮件提取到各个项目文件夹中。因此，在意识到您可以从 Outlook 中提取的副本实际上是无法排序的，并且不会保留任何元数据后，我开始寻找其他解决方案。并找到了一些部分 VBA 脚本来执行此操作，我将它们拼凑在一起并在此处更改以尝试获得我想要的。

该例程从 Outlook 中读取选择，并将电子邮件保存到提供的位置，并根据需要使用时间戳和发件人或收件人。分类到子文件夹中。这部分似乎工作得很好。但在我的测试中，我在一个包含 238 封电子邮件的 Outlook 文件夹中运行，我的测试日志有 233 个条目，但只输出了 231 个文件。有什么想法吗？

会不会是文件夹太大了？这样我可能需要在较小的部分中进行。还是超前，以至于我需要在某处添加延迟？

Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim enviro As String
    Dim sUser As String
    Dim fso As Object
    Dim log As Object
    Dim count As Integer

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set log = fso.CreateTextFile("C:\TestLog.txt", True)
    count = 1

    sUser = "UserName"  'During test this was the actual name
    enviro = CStr(Environ("USERPROFILE"))

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sUser + "_" + sName + ".msg"
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName + ".msg"
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            log.WriteLine (CStr(count) + "/" + CStr(ActiveExplorer.Selection.count) + " - " + sPath + sName)
            oMail.SaveAs sPath + sName, olMSG
            count = count + 1
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function

【问题讨论】：

在您的选择中，您确定它们都是MailItem.MessageClass？ - "IPM.Note" 查看物品并找出它们的类型或物品

我相信是这样，但我会检查以确保。我正在使用其中一位项目经理的电子邮件作为我的测试用例，所以他可能在里面塞了一个日历对象或其他东西，我会检查一下。

也尝试使用For i = 1 To ActiveExplorer.Selection.Count循环

好吧，我为 NOT "IPM.Note" 添加了一个条件。这解决了部分问题。有 6 个条目不是 IPM。注意，但实际上是日历约会消息。这让我在日志文件中找到 233 个条目，在文件夹中找到 233 条消息。但脚本仍然只输出 231 个文件。我会看看更改为 for 循环对它有什么影响。

文件在通过代码保存时会被覆盖而不会发出警告。

【参考方案1】：

感谢上面 cmets 中的 0m3r 和 niton 帮助我解决了这个问题。里面有一些日历笔记当然不是电子邮件，所以它们必须被删除，还有几封电子邮件以相同的发件人、时间和主题到达，所以脚本会覆盖它们。

在此之后，我在其他机器上获取 Outlook 以允许宏运行时遇到了一些问题。所以我回去并将其重写为 C# 中 Outlook 的 VSTO 插件。我更改的唯一功能是让 RemoveSpecials 检查除时间之外的所有内容，并添加了路径长度检查，因此生成的字符不会超过 260 个。这会导致事情停止。

这是我迁移到 c# 之前的 VBA 脚本

Option Explicit

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sRootPath As String
    Dim sPath As String
    Dim sLastPath As String
    Dim dtDate As Date
    Dim sDate As String
    Dim sTime As String
    Dim sName As String
    Dim sFrom As String
    Dim sTo As String
    Dim sCC As String
    Dim sBCC As String
    Dim sUser As String
    Dim sExtension As String
    Dim iRepeatCount As Integer

    iRepeatCount = 1
    sLastPath = ""
    sExtension = ".msg"

    sUser = "Username"  'During test this was the actual name

    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    Dim fd As Office.FileDialog
    Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)

    With xlApp.Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sRootPath = .SelectedItems(1)
        End If
    End With

    Set fd = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    Dim i As Integer

    For i = 1 To ActiveExplorer.Selection.count
        If ActiveExplorer.Selection.Item(i).MessageClass = "IPM.Note" Then
            Set oMail = ActiveExplorer.Selection.Item(i)
            sName = oMail.Subject
            sName = RemoveSpecials(sName)
            dtDate = oMail.ReceivedTime
            sFrom = oMail.SenderName
            sTo = oMail.To
            sCC = oMail.CC
            sBCC = oMail.BCC
            sDate = Format(dtDate, "yyyy.mm.dd", vbUseSystemDayOfWeek, vbUseSystem)
            sTime = Format(dtDate, "-hh.nn.ss", vbUseSystemDayOfWeek, vbUseSystem)
            sPath = sRootPath
            If InStr(sFrom, sUser) > 0 Then
                sName = sDate + sTime + "_" + sTo + "_" + sName
                sPath = sPath + "\To\"
            ElseIf InStr(sCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\CC\"
            ElseIf InStr(sBCC, sUser) > 0 Then
                    sName = sDate + sTime + "_" + sFrom + "_" + sName
                    sPath = sPath + "\BCC\"
            Else
                sName = sDate + sTime + "_" + sFrom + "_" + sName
                sPath = sPath + "\Received\"
            End If
            If Dir(sPath, vbDirectory) = "" Then
                MkDir sPath
            End If

            If sPath + sName + sExtension = sLastPath Then
                sName = sName + "(" + CStr(iRepeatCount) + ")"
                iRepeatCount = iRepeatCount + 1
            Else
                iRepeatCount = 1
                sLastPath = sPath + sName + sExtension
            End If
            oMail.SaveAs sPath + sName + sExtension, olMSG            
        End If
    Next
End Sub

Function RemoveSpecials(strInput As String) As String
    Dim strChars As String
    strChars = "!£$%^&*()_+@~:<>?,./;'#[]-=`¬¦" & Chr(34)
    Dim intIndex As Integer
    For intIndex = 1 To Len(strChars)
        strInput = Replace(strInput, Mid(strChars, intIndex, 1), "")
    Next
    RemoveSpecials = strInput
End Function

【讨论】：

您会发现，一般情况下，您需要通过 RemoveSpecials 将文件名中使用的所有文本放入。我发现 sFrom 可能包含无效字符。