65.9K
CodeProject 正在变化。 阅读更多。
Home

将所有 Outlook 邮件项目保存到单独的文件

E.F. Nijboer
starIconstarIconstarIconstarIcon
emptyStarIcon
starIcon

4.33/5 (6投票s)

2010年7月15日

CPOL

3分钟阅读

viewsIcon

46218

downloadIcon

1101

将邮件项目保存到单独文件并保留文件夹结构的源代码。

引言

此代码将遍历所有 Outlook 文件夹，并将每个邮件项保存为单独的文件，同时保留文件夹结构。代码非常基础，没有用户界面。这是一个简单的示例，说明如何将电子邮件消息单独存储，而不是存储在一个大的 PST 文件中。

背景

我认识的一个人想将他的电子邮件消息存储为单独的文件，而不是像 Outlook 的导出功能那样存储在一个大文件中。这段代码就能做到这一点。

Using the Code

在 Outlook 中打开 Visual Basic 编辑器并将下面的代码复制粘贴进去，即可立即运行，它会将收件箱中的所有邮件项保存到C:\Temp文件夹。启动方法是SaveAllMail。如果打开了立即窗口，它还会提供一些进度反馈。

Option Explicit
Const PATHSEPARATOR = "\"
Const MAIL_DIRECTORY = "C:\Temp"
Const MAIL_SAVETYPE = olMSG      ' olHTML, olMSG, olRTF, olTemplate, 
                            'olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode.
Const MAIL_SAVEFILE_EXT = ".msg"
  • MAIL_DIRECTORY - 保存项的目录
  • MAIL_SAVETYPE - 保存的邮件项的文件类型
  • MAIL_SAVEFILE_EXT - 保存的邮件项的文件扩展名

这些常量定义了邮件项的存储方式，其中MAIL_SAVETYPE和MAIL_SAVEFILE_EXT的值是相互关联的。例如，当MAIL_SAVETYPE更改为 olHTML 时，MAIL_SAVEFILE_EXT的值也应相应更改，以匹配输出文件格式。对于 olHTML，这当然应该是“.htm”（如果喜欢，也可以是“.html”）。

Public Sub SaveAllMail()
    ' Save all mail items in the inbox folder
    ProcessFolder ThisOutlookSession.Session.GetDefaultFolder(olFolderInbox), _
	MAIL_DIRECTORY, True
    
    ' The line below would scan all outlook folders.
    'ProcessFolders ThisOutlookSession.Session.Folders, MAIL_DIRECTORY, True
End Sub

SaveMailItem方法是此示例中的主要方法。当前的起始点是收件箱文件夹。因为这是一个单独的文件夹，所以会调用ProcessFolder。目前被注释掉的第二个起始点可用于文件夹集合。

例如，如果只想存储收件箱的子文件夹，而不存储收件箱本身的邮件项，则可以使用以下方法：

ProcessFolder ThisOutlookSession.Session.GetDefaultFolder(olFolderInbox).Folders, _
	MAIL_DIRECTORY, True
Public Sub ProcessFolder(Folder As Outlook.Folder, ByVal Directory As String, _
	ByVal Recursive As Boolean)
    Dim FolderDirectory As String
    FolderDirectory = Directory & PATHSEPARATOR & Folder.Name
    CreateDirectory FolderDirectory
    DebugPrint Folder.Name
    ProcessItems Folder.Items, FolderDirectory
    If Recursive Then
      ProcessFolders Folder.Folders, FolderDirectory, Recursive
    End If
End Sub
Public Sub ProcessFolders(Folders As Outlook.Folders, _
	ByVal Directory As String, ByVal Recursive As Boolean)
  Dim Folder As Outlook.MAPIFolder
  For Each Folder In Folders
    ProcessFolder Folder, Directory, Recursive
  Next
End Sub

上面的两个方法处理已找到的文件夹和文件夹。这些函数以递归方式（如果Recursive参数为true）相互调用，以便每个文件夹都会遍历所有子文件夹，并且这些子文件夹中的每个文件夹都是递归重新开始的地方。

Private Sub PrintMailItemsProcessed(NumOfProcessedItems As Long)
    DebugPrint "  Mail items processed: " & CStr(NumOfProcessedItems)
End Sub

上面的PrintMailItemsProcessed方法仅用于将已处理的邮件项打印到调试窗口。

Private Sub ProcessItems(Items As Outlook.Items, ByVal Directory As String)
  Dim Item As Object, MailItemNumber As Long
  MailItemNumber = 0
  DebugPrint " Total number of items: " & CStr(Items.Count)
  For Each Item In Items
    Select Case True
      Case TypeOf Item Is Outlook.MailItem
        MailItemNumber = MailItemNumber + 1
        MailItemToFile Item, Directory, MailItemNumber
        If (MailItemNumber And 7) = 7 Then
          PrintMailItemsProcessed MailItemNumber
        End If
      Case TypeOf Item Is Outlook.ContactItem
        ' ...
      Case TypeOf Item Is Outlook.MeetingItem
        ' ...
      Case TypeOf Item Is Outlook.JournalItem
        ' ...
      Case Else
        ' ...
    End Select
  Next
  PrintMailItemsProcessed MailItemNumber
End Sub

ProcessItems方法是识别项并调用特定方法的地方。目前只处理MailItem，但其他一些项类型已被识别但留空。此示例中甚至没有识别出更多项类型。

Private Sub MailItemToFile(Item As Outlook.MailItem, _
	ByVal Directory As String, ItemNumber As Long)
    Item.SaveAs Directory & PATHSEPARATOR & CStr(ItemNumber) _
	& " - " & ReplaceIllegalChars(Item.Subject) & MAIL_SAVEFILE_EXT, MAIL_SAVETYPE
End Sub

MailItemToFile方法会将给定的邮件项以定义的格式保存到相应的目录。该方法不会将附件保存到文件，但这可以很容易地自行添加。只需遍历mailitem的附件并将每个附件保存到给定位置，就像下面的示例一样

For Each Item In Item.Attachments
    Atmt.SaveAsFile Directory & PATHSEPARATOR & CStr(ItemNumber) & " " & & Atmt.FileName
Next Atmt
'-----------------------------------------------------------------------------------------
' Some general methods used
'-----------------------------------------------------------------------------------------
Private Sub DebugPrint(ByVal DebugMessage As String)
    Debug.Print DebugMessage
    DoEvents
End Sub

DebugPrint方法仅会将一些信息打印到立即窗口，并添加了DoEvents调用以防止 Outlook “无响应”。

Public Sub CreateDirectory(ByVal Directory As String)
    If Dir(Directory, vbDirectory) = vbNullString Then
        MkDir Directory
    End If
End Sub
' This function will replace all illegal characters with the ReplaceChar
Private Function ReplaceIllegalChars(S As String, _
	Optional ReplaceChar As Byte = 32) As String
    Dim index As Integer, CharArray() As Byte, ResultArray() As Byte
    If Len(S) > 0 Then
        CharArray = StrConv(S, vbFromUnicode)
        ReDim ResultArray(UBound(CharArray))
        For index = 0 To UBound(CharArray)
            Select Case Chr(CharArray(index))
                Case "/", "\", ":", "?", "*", "<", ">", "|", """"
                    ResultArray(index) = ReplaceChar
                Case Else
                    ResultArray(index) = CharArray(index)
            End Select
        Next
        ReplaceIllegalChars = StrConv(ResultArray, vbUnicode)
    Else
        ReplaceIllegalChars = vbNullString
    End If
End Function

ReplaceIllegalChars方法将从给定的string中删除不允许在文件名中使用的字符，并在本例中用于在将邮件主题用作文件名之前剥离非法字符。字符将被替换为ReplaceChar参数中给定的字符。这必须是代表字符 ASCII 值的单字节值。内置的Asc函数可用于将字符转换为 ASCII 值。

查看此函数的代码时，您可能会注意到S被转换为字节数组，并且定义了一个等效数组来保存结果。这样，就可以一次性分配所需的内存，而不是一次只添加一个字符。在处理大型string值时，这种处理string中字符的方法速度明显更快。

关注点

如开头所述，此示例非常基础，您可以轻松地对其进行扩展，以提供满足您所有愿望的功能。这是一个可行的起点，用于探索 Outlook 的其他可能性，也许可以通过自动化使您的生活更轻松。

© . All rights reserved.