将Outlook邮件项目保存到本地文件夹

Question

下面的代码完成了我想要的一切：提取电子邮件、保存附件、提取文件除非将原始电子邮件保存到文件夹fDest。我似乎看不出解决办法。

这似乎是有问题的一行，因为它不会保存电子邮件："mi.SaveAs fDest2，olMSG"；

Sub SaveAttachments()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim Inbox As MAPIFolder
Dim strDate As String
Dim oApp As Object
Dim fDest As Variant
Dim j As Variant
Dim sh As String
Dim FileDialog As FileDialog
Dim Tracker As Workbook
Dim fSheet As Sheets
Dim LastRow As Long
Dim strFilePath
Dim fTracker As Workbook

strDate = InputBox("Enter Date in format dd-Mmm-yyyy", "User Date", Format(Now(), "dd-Mmm-yyyy"))
strFilePath = "\namdfsCARDSMWDGROUPSGCM_NAM20215 May"
fTrackerName = "Inquiry.Tracker.SWPA.Violations.May.2021.xlsx" '
On Error Resume Next
Set fTracker = Workbooks(fTrackerName)
'If Err Then Set fTracker = Workbooks.Open(strFilePath & fTrackerName)
On Error GoTo 0
'Windows(fTrackerName).Activate

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("GCMNamLogs").Folders("Inbox")

fDest = "C:Usersjb76991DesktopViolations_Emails"
fUser = UCase(Environ("username")) & ":" & Chr(10) & Now()

For Each i In fol.Items.Restrict("@SQL=urn:schemas:httpmail:subject LIKE '%" & strDate & "%'")
'Debug.Print fDest & i & ".msg"
If i.Class = olMail Then
Set mi = i
fDest2 = fDest & mi.Subject & ".msg"
mi.SaveAs fDest2, olMSG
For Each at In mi.Attachments
'do something with attachments but i've commented it out
Next at
End If
Next i
MsgBox ("Completed")

End Sub

有人能告诉我如何保存正在筛选的原始电子邮件吗？

Answer 1

您必须确保文件名中没有无效字符。请参阅Windows和Linux目录名中禁止使用哪些字符？了解更多信息。因此，在将任何内容传递给SaveAs方法之前，我建议使用VBA中可用的Replace方法。

另一点是，您需要为每封电子邮件指定唯一的文件名。请确保生成的文件名对于文件夹是唯一的。