下面这段程序能够实现将你选中的邮件以MSG格式保存到一个目录中,并且生成一个包含邮件内容的TXT文件。举例来说:你在Outlook中选中200封邮件,然后指定 c:\m\ 作为存储目录。运行之后你就会发现,m目录中出现 0 1 2 3....这样的目录,其中是以MSG格式保存的每封邮件,并且每个目录下还有其中邮件TXT格式的内容。程序是以20MB为限,当一个目录中的邮件大于20MB时自动创建另外的目录。之所以选择20MB是因为通常的Mail系统所支持的附件的上限是这个数值。因此,你可以将生成的TXT作为正文,压缩之后的目录作为附件发送到你的邮件服务器上。比较推荐的是 QQ Mail,容量足够大,速度也不慢。当然如果你不放心,或者说觉得它的速度慢,还可以选择一个对你来说速度快的免费邮件服务器,然后在QQ Mail中设定自动收取这个邮箱的邮件。因为 QQ Mail的容量是一直增长的,所以不必担心邮箱爆掉。另外,QQ Mail提供了一个全文搜索的功能,使用户可以很方便的搜索到文件的内容----这也是为什么要按照TXT保存邮件正文一次。
Function ReplaceCharsForFileName(sName As String) As String
sName = Replace(sName, "/", " ", 1, -1)
sName = Replace(sName, "\", " ", 1, -1)
sName = Replace(sName, ":", " ", 1, -1)
sName = Replace(sName, "?", " ", 1, -1)
sName = Replace(sName, "<", " ", 1, -1) sName = Replace(sName, ">", " ", 1, -1)
sName = Replace(sName, "|", " ", 1, -1)
sName = Replace(sName, "*", " ", 1, -1)
'chr(34)='"'
sName = Replace(sName, Chr(34), " ", 1, -1)
ReplaceCharsForFileName = sName
End Function
Sub SaveChooseFile()
Dim objItem As Object
Dim strPath As String
Dim strFilePath As String
Dim iSize As Long
Dim iNum As Integer
Dim objFSO As Object
'exit if you do not choose any files
If ActiveExplorer.Selection.Count = 0 Then Exit Sub
'the path string should be ended by "\"
strPath = InputBox("please enter a path :", " Enter path")
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'File size counter
iSize = 0
'Directory counter
iNum = 0
For Each objItem In ActiveExplorer.Selection
'Create file and dir
If iSize = 0 Then
strFilePath = strPath & Str(iNum)
If Not (objFSO.FolderExists(strFilePath)) Then
objFSO.CreateFolder (strFilePath)
End If
Set ts = fso.CreateTextFile(strFilePath & "\" & Str(iNum) & "Body.txt", ForAppending, True)
End If
iSize = iSize + objItem.Size
'write all the chosen file to a file
ts.Write ("==============================================================" & vbCrLf)
ts.Write (objItem.ReceivedTime & vbCrLf)
ts.Write (objItem.SenderName & vbCrLf)
ts.Write (objItem.Subject & vbCrLf)
'Meeting requirement doesn't have 'to' field
If (objItem.Class <> olMeetingRequest) _
And (objItem.Class <> olMeetingCancellation) _
And (objItem.Class <> olMeetingResponseNegative) _
And (objItem.Class <> olMeetingResponsePositive) _
Then ts.Write (objItem.To & vbCrLf)
ts.Write (objItem.Body & vbCrLf)
ts.Write ("==============================================================")
'save the mail as MSG format
objItem.SaveAs strFilePath & "\" & ReplaceCharsForFileName(objItem.Subject) & ".MSG", OlSaveAsType.olMSGUnicode
'save the contents to another text if the size is larger than 20MB
If iSize >= 20971520 Then
iSize = 0
iNum = iNum + 1
ts.Close
End If
Next
MsgBox "Email text extraction completed!", vbOKOnly + vbInformation, "DONE!"
ts.Close
Set objItem = Nothing
End Sub
额外的问题:有时候在保存邮件的过程中会出现如下错误:
当出现错误的时候,可以切换到Debug下面,通过查看邮件的标题得知出现问题的邮件是那封,删除这个邮件即可。这并不是上面程序本身导致的,对于导致问题的邮件,你使用Outlook 直接保存为MSG文件也会出现同样的问题,目前我只在一些会议邀请的邮件上遇到过这样的问题,如果你没有这类邮件应该不会遇到这个问题。