在Outlook中用VBA导出HTML格式邮件

时间:2024-03-17 15:57:09

我每天所收到的e-mail中,订阅的电子杂志占了很大的比例。其中既有新闻也有电脑技术或娱乐性文章,加在一起竟有上百封。后来我知道单位里许多人同我一样也喜欢看,而且有的人还订了同样的杂志,所以我就每天收到邮件后把它们整理到局域网上去。只是这么多的邮件,整理起来工作量可不小,怎么解决一下呢?

   这些邮件通常都是HTML格式的,用Outlook通常的方法不能正确的导出,而且分布在许多下层子夹中,导出很麻烦。我在OUTLOOK中,用VBA实现了HTML邮件导出并自动发布到网络上。

   要对邮件箱里的邮件进行操作,首先要取得Outlook MAPI名字空间。可以使用下面的语句:

   Dim mobjOutlook As Outlook.NameSpace

   Dim objOutlook As New Outlook.Application

   mobjOutlook=objoutlook.GetNameSpace(“MAPI”)

   用mobjOutlook的GetDefaultFolder方法。可以取得收件箱的MAPIFolder对象:

   Dim objFolder As Outlook.MAPIFolder

   ObjFolder=mobjOutlook.GetDefaultFolder(6)

   其中参数6代表收件箱,其他参数的意义如下表:

常量

数值

描述

   OlFolderDeletedItems

3

已删除邮件

OlFolderOutbox

4

发件箱

OlFolderSentMail

5

已发件邮件

olFolderInbox

6

收件箱

OlFolderCalendar

9

日历

OlFolderContacts

10

联系人

olFolderJournal

11

日记

olFolderNotes

12

便笺

olFolderTasks

13

任务

olFolderDrafts

16

草稿

   在objFolder的属性包含邮件项集合即ITEMS,也包含所有下一级子夹的集合Folders。

   对每一个邮件,首先取得邮件的接收时间,如果是当天收到的就创建并打开一个HTML文件,以其主题Subject为文件名,把它的HTML格式的内容,即HTMLBody属性的值写入这个文件,然后关闭并处理下一个。

   对下一级子夹,用递归调用的方式,可以遍历收件箱中每一层夹中的所有邮件。在生成邮件文件时,还同时生成索引文件。

完整的程序如下:

   Private mobjOutlook As Outlook.NameSpace

   Private fs, fo

   Private Sub GetOutlook()

   Dim objOutlook As New Outlook.Application

   Set mobjOutlook = objOutlook.GetNamespace("MAPI")

   End Sub

   Sub ListMailFolders(objFolder As Outlook.MAPIFolder)

   Dim objItem As Object

   Dim f

   Dim str1, str2, str3 As String

   For Each objItem In objFolder.Items

   If (FormatDateTime(objItem.ReceivedTime, vbShortDate) = FormatDateTime(Date, vbShortDate)) Then

   str2 = objItem.Subject

   str1 = "j:wwwrootnews" + str2 + ".htm"

   Set f = fs.OpenTextFile(str1, 2, True, TristateFalse)

   f.Write objItem.HTMLBody

   f.Close

   str3 = "< p>< a href=\'" + objItem.Subject + ".htm\'>" + objItem.Subject + "< /a>< /p> "

   fo.Write str3

   End If

   Next

   Dim objf As Outlook.MAPIFolder

   For Each objf In objFolder.Folders

   ListMailFolders objf

   Next

   Set objItem = Nothing

   End Sub

   Sub ListMailItems(longFolder As Long)

   Dim objFolder As Outlook.MAPIFolder

   Dim f

   If mobjOutlook Is Nothing Then

   GetOutlook

   End IF

   Set objFolder = mobjOutlook.GetDefaultFolder(longFolder)

   ListMailFolders objFolder

   End Sub

   Private Sub storemail()

   Set fs=CreateObject(“Scripting.FileSystemObject”)

   Set fo=fs.OpenTextFile(“j:wwwrootnewsindex.html”,2,True,TristateFalse)

   fo.Write “< HTML>< HEAD>< META content=’text/html; charset=gb2312’ http-equiv=Content-Type> < TITLE>< /TITLE>< /HEAD>< BODY>

   ListMailItems(6)

   fo.Write “< /BODY>< /HTML>”

   fo.Close

   End Sub

   在Outlook2000中创建一个新的宏,用VB编辑器编辑它,把上面的程序拷贝到同一模块,注意把生成文件的目录名改为自己WEB服务器上的WWW服务根文件夹名。在宏中调用storemail,执行宏,就可以导出当天收到的所有邮件。

   所有指向这些HTML文件的链接放在同一目录下的index.html中,这样每个人都可以在网上浏览这些文章了。