[原创]将收件箱中的邮件逐个导出为MSG文件，并将其附件另存在硬盘上

henrry

Private Sub DumpMail()
Dim myNameSpace As NameSpace
Dim myFolder As MAPIFolder
Dim Mi As MailItem
Dim At As Attachment
Dim I%, J%, sTime$, Ssubject$

Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For I = 1 To myFolder.Items.Count
Set Mi = myFolder.Items(I)
sTime = Format(Mi.ReceivedTime, "yyyy-mm-dd hh/mm/ss")
Ssubject = Mi.Subject
Ssubject = Replace(Ssubject, "/", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, "\", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, ":", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, "*", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, "?", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, """", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, "<", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, ">", "", , , vbTextCompare)
Ssubject = Replace(Ssubject, "|", "", , , vbTextCompare)
Mi.SaveAs "d:\" & Ssubject & "-" & sTime & ".msg", olMSG
If Mi.Attachments.Count > 0 Then
For Each At In Mi.Attachments
At.SaveAsFile "d:\" & At.FileName
Next
End If
Next


Set Mi = Nothing
Set myFolder = Nothing
Set myNameSpace = Nothing
End Sub