【发布时间】：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 循环对它有什么影响。
-
文件在通过代码保存时会被覆盖而不会发出警告。