这是我正在寻找的：
我在 Outlook 中有 20 个不同的文件夹，每个文件夹都有相同的电子邮件正文结构和格式。每个电子邮件正文都有 3 到 7 个超链接我想导出其中一个超链接（它很容易识别，因为它具有相同的起始/特定单词 - 我们是否导出这个特定超链接或全部都没有关系，因为我们以后可以在 excel 中编辑它们）。
我希望将这些超链接导出到 Excel 工作表中的单元格中
我现在在做什么：
我正在使用剪贴板转到每封电子邮件。右键单击复制链接，然后粘贴到记事本或 Excel 中。
让我知道你们是否有任何建议。这将真正简化我的工作......当然还有其他任何可能寻找类似解决方案的人。
问候，
AA
可以导出到excel，但是在复制到excel之前，
-> 您必须选择存在超链接的电子邮件。通过选择电子邮件右键单击并选择 发送到一个笔记。
->一个音符将打开。翻阅 One-note 的此部分（右侧）中的页面选项卡。选择所有邮件（页面）并右键单击->复制。
您可以找到或应用过滤器，过滤器->文本过滤器->包含所需的单词或短语（它很容易识别，因为它具有相同的起始/特定单词）。
如果你直接从onenote复制到excel，意味着所有表格、附件等都会被粘贴，那么过滤或查找需要的超链接会很困难。
由于您说的是 20 个文件夹，因此无法将文件夹发送到onenote，您需要打开 20 个文件夹，然后您可以在每个文件夹中选择任意数量的电子邮件。
:)
我无法将我的解决方案放在一个答案中，因为它超出了大小限制。 这是我回答的第 1 部分。 我已将一段代码移至第二个答案。
这是一个 VBA 解决方案。你给出了一个很好的规范，所以我相信这将接近你的要求。我希望我已经包含了足够的评论，以便您进行最终调整。如果没有，请问。
第一个代码块包含我为我编写的子例程。他们执行我认为有用的任务。它们包括评论，但它们是为了提醒我他们不帮助别人理解它们而写的评论。我为您编写的宏会使用它们，并且我会解释如何使用它们。目前，我建议您不要担心这些子例程如何完成它们的工作。
我或许应该警告你，我很少在自己的宏中使用错误处理功能，因为我不希望它们优雅地失败；我希望他们停止问题陈述，以便我能够理解并纠正原因。
在 Outlook 中，打开 VBA 编辑器，插入一个模块并将第一个代码块复制到其中。您还需要单击Toolsthen References。“Microsoft Excel nn.n 对象库”是否在顶部附近，是否打勾？如果未勾选，您必须滚动完成列表，找到此参考并勾选它。“nn.n”的值取决于您使用的 Excel 版本。只有当您安装了多个版本的 Excel 时，您才有选择的余地。
答案在代码下方继续。
此代码移至答案的第二部分。
下面是四个宏。前三个是教程，第四个是我的解决方案。
如果您的 Outlook 安装与我的一样，您将拥有文件夹Personal Folders、Archive Folders，也许还有其他文件夹。在个人文件夹中，您将拥有标准文件夹收件箱、发件箱等。您可能在这些标准文件夹中添加了自己的文件夹，或者您可能已将它们添加到个人文件夹中。在我自己的系统上，我有各种文件夹，包括!Family和!Tony。每个都包含子文件夹和!Tony中的子文件夹之一是Amazon。
在第一个宏中，你最需要理解的语句：
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
FindInterestingFolders是上面代码中包含的子例程之一。该语句的第二行以我觉得方便的方式指定了我提到的两个文件夹的名称。该宏FindInterestingFolders返回有关这两个文件夹以及它们可能拥有的任何子文件夹或子子文件夹的信息。您必须将这两个名称替换为您要搜索的文件夹。如果 20 个文件夹都在一个父级下，您可以指定该单个父级。如果 20 个文件夹分散，您可能必须指定所有 20 个文件夹的名称。
第一个宏将 . 找到的所有文件夹的名称输出到即时窗口FindInterestingFolders。在我的系统上，它输出：
Personal Folders|!Family|Chloe & Euan
Personal Folders|!Family|Geoff
Personal Folders|!Family|Lucy & Mark
Personal Folders|!Tony|Amazon
Personal Folders|!Tony|Amazon|Trueshopping Ltd
将此宏复制到您在上面创建的模块中并使用它，直到您创建一个包含 20 个要搜索的文件夹的列表。
答案在代码下方继续。
Sub ExtractHyperLinks1()
' Outputs a sorted list of interesting folders to the Immediate Window.
Dim FolderList() As MAPIFolderDtl
Dim InxFL As Long
' Set FolderList to a list of interesting folders.
' The True means a folder has to containing mail items to be interesting.
' The False means I am uninterested in meeting items.
' The "|" defines the name separator used in the list of folder names
' that follow.
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
With FolderList(InxFL)
Debug.Print .NameParent & "|" & .Folder.Name
End With
Next
End Sub
希望这不是太难。您必须将修改后的调用复制FindInterestingFolders到以下宏中。
宏 2 建立在宏 1 的基础上。它在有趣的文件夹中搜索带有 Html 正文的邮件项目。对于每个 Html 正文，它会搜索锚标记并将每个标记和接下来的 58 个字符输出到即时窗口。即时窗口仅显示最后 200 行左右，因此您可能只能看到输出的底部。这没关系；这个想法是让您先看看宏可以看到什么。在我的系统上，输出结束：
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from Amazon customer ...
<A HREF="mailto:16dhtcxlxwbh7fx@marketplace.amazon.co.uk">ma
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product details enquiry ...
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
<A HREF="http://www.amazon.co.uk/gp/help/customer/display.ht
标题行包含邮件项目的发件人、接收时间和主题。
将此宏添加到模块中，将修改后的调用复制到FindInterestingFolders我的调用顶部并运行它。几乎立即，您将被警告宏正在访问电子邮件。您必须授予宏继续的权限并选择一个时间段以继续。我假设您将安全级别设置为标准的“中”。如果您将其设置为不同的值，您将获得不同的选项。
答案在代码下方继续。
Sub ExtractHyperLinks2()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an anchor.
' For each such mail item it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject
' First 60 characters of first anchor
' First 60 characters of second anchor
' First 60 characters of third anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim PosAnchor As Long
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might have a hyperlink.
If InStr(1, LCase(.HtmlBody), "<a ") <> 0 Then
' It has at least one anchor
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
Debug.Print " " & Mid(.HtmlBody, PosAnchor, 60)
PosAnchor = InStr(PosAnchor + 1, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
我再次希望这很容易。我不确定下一个宏有多大用处。这是我开发的一个步骤，但它没有包含在最终宏中不重要的内容。可能值得您研究它，因为最终的宏将与宏 2 相比有两个重要的变化。
宏 3 所做的是从锚标记中提取 URL，并丢弃那些以“mailto:”开头的 URL。Html 允许的变化比我所允许的要多，因为我从未见过利用这种灵活性的电子邮件。如果您的电子邮件与我的预期不同，您可能必须增强我的代码。您只需要每封电子邮件中的一个 URL，因此您可能希望添加代码以丢弃其他 URL。
同样，将此宏添加到模块中，将修改后的调用复制到FindInterestingFolders我的调用顶部并运行它。在我的系统上，输出的最后几行是：
Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
Trueshopping Ltd - Amazon Marketplace 14/02/2012 09:08:39 RE: Product ...
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=11081621
http://www.amazon.co.uk/gp/help/customer/display.html?nodeId=3149571
答案在代码下方继续。
Sub ExtractHyperLinks3()
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the Immediate Window:
' Name of folder (if not already output for an earlier mail item)
' Sender ReceivedTime Subject (if not already output)
' Url from acceptable anchor
Dim FolderList() As MAPIFolderDtl
Dim FolderNameOutput As Boolean
Dim InxFL As Long
Dim InxItem As Long
Dim ItemHeaderOutput As Boolean
Dim LcHtmlBody As String
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim Url As String
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderNameOutput = False
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
ItemHeaderOutput = False
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
If Left(LCase(Url), 7) <> "mailto:" Then
' I am interested in this url
If Not FolderNameOutput Then
Debug.Print FolderList(InxFL).NameParent & "|" & _
FolderList(InxFL).Folder.Name
FolderNameOutput = True
End If
If Not ItemHeaderOutput Then
Debug.Print " " & .SenderName & " " & _
.ReceivedTime & " " & .Subject
ItemHeaderOutput = True
End If
Debug.Print " " & Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a ")
Loop
End If
End If
End If
End With
Next
End With
Next
End Sub
对于最后一个宏，我在用于开发答案的工作簿之一中创建了一个工作表。
在最终的宏中，您将找到以下语句：
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
您需要将其替换为工作簿的路径和文件名。
您还会发现以下声明：
Const WkShtName As String = "URLs"
我使用了工作表URL。我建议您首先创建一个像我这样的工作表。一旦你完成了最终的宏工作，你就可以根据你的要求对其进行调整。
我的工作表中有四列：文件夹名称、发件人名称、接收时间和 URL。第三列包含完整的日期和时间，但我将其格式化为仅显示一个短日期。您的问题中没有任何内容表明您想要这些额外的列。我认为值得展示您可以做什么，如果代码不有趣，您可以删除代码。
我确实认为您需要对 Received Time 做一些事情。除非您将已处理的电子邮件移出 20 个文件夹，否则每次运行宏都会再次添加完整的 URL 集。有许多技术可以不再处理电子邮件。例如，您可以将用户类别添加到已处理的电子邮件中。但是，我怀疑最简单的方法是：
我在最终的宏中包含了很多注释，解释了我如何积累数据并将其写入工作表，所以我不会在这里重复自己。祝你好运，并重复开始时的说明，询问是否有任何不清楚的地方。
同样，将此宏添加到模块中，将修改后的调用复制到FindInterestingFolders我的调用顶部。这次您还必须在运行宏之前更新一个或两个常量语句。
Sub ExtractHyperLinks()
' Open destination workbook.
' Find last used row in destination worksheet.
' Gets a list of interesting folders.
' Searches the list for mail items with Html bodies that contain an
' acceptable anchor. An acceptable anchor is one for which the url
' does not start "mailto:".
' For each acceptable anchor it outputs to the workbook:
' Column 1 := Name of folder
' Column 2 := Sender
' Column 3 := ReceivedTime
' Column 4 := Url
Dim ExcelWkBk As Excel.Workbook
Dim FolderList() As MAPIFolderDtl
Dim FolderName As String
Dim InterestingURL As Boolean
Dim InxOutput As Long
Dim InxFL As Long
Dim InxItem As Long
Dim ItemCrnt As MailItem
Dim LcHtmlBody As String
Dim OutputValue(1 To 50, 1 To 4)
Dim PosAnchor As Long
Dim PosTrailingQuote As Long
Dim PosUrl As Long
Dim Quote As String
Dim RowNext As Long
Dim TargetAddr As String
Dim Url As String
' Replace constant value with path and file name of your workbook.
Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls"
Const WkShtName As String = "URLs"
Set ExcelWkBk = Application.CreateObject("Excel.Application"). _
Workbooks.Open(WkBkPathFile)
With ExcelWkBk
.Application.Visible = True ' Slows the macro but helps during testing
With .Worksheets(WkShtName)
' Find last used row in destination worksheet by going to bottom of sheet
' then moving up until a non-empty row is found then going down one.
' .End(xlUp) is VBA equivalent of Ctrl+Up.
RowNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
End With
End With
Call FindInterestingFolders(FolderList, True, False, "|", _
"Personal Folders|!Family", "Personal Folders|!Tony|Amazon")
InxOutput = 0
For InxFL = LBound(FolderList) To UBound(FolderList)
FolderName = FolderList(InxFL).NameParent & "|" & FolderList(InxFL).Folder.Name
With FolderList(InxFL).Folder
For InxItem = 1 To .Items.Count
With .Items.Item(InxItem)
If .Class = olMail Then
If .HtmlBody <> "" Then
' This mail item has an Html body so might contain hyperlinks.
LcHtmlBody = LCase(.HtmlBody)
If InStr(1, LcHtmlBody, "<a ") <> 0 Then
' It has at least one anchor
PosAnchor = InStr(1, LCase(.HtmlBody), "<a ")
Do While PosAnchor <> 0
PosUrl = InStr(PosAnchor, LcHtmlBody, "href=")
PosUrl = PosUrl + 5
Quote = Mid(LcHtmlBody, PosUrl, 1) ' Extract quote used in html
PosUrl = PosUrl + 1
PosTrailingQuote = InStr(PosUrl, LcHtmlBody, Quote)
Url = Mid(.HtmlBody, PosUrl, PosTrailingQuote - PosUrl)
InterestingURL = True ' Assume interesting until find otherwise
If Left(LCase(Url), 7) = "mailto:" Then
InterestingURL = False
End If
' **********************************************************
' Set InterestingURL = False for any other urls you want
' to reject. If you can tell a URL is ininteresting by
' looking at it, you can use code like mine.
' **********************************************************
If InterestingURL Then
' This URL and supporting data is to be output to the
' workbook.
' Rather than output data to the workbook cell by cell,
' which can be slow, I build it up in the array
' OutputValue(1 to 50, 1 To 4). It is normal in a 2D array
' for the first dimension to be for columns and the second
' for rows. Arrays to be read from or written to a worksheet
' are the other way round. You can resize the second
' dimension of a dynamic array but not the first so you
' cannot resize an array being built for a workbook. I
' cannot resize the array so I have fixed its size at
' compile time.
' This code fills the array, writes it out to the workbook
' and resets the array index. I have 50 rows because I
' wanted to test the filling and refilling of the array. I
' would suggest you make it bigger.
InxOutput = InxOutput + 1
If InxOutput > UBound(OutputValue, 1) Then
' Array is fill. Output it to workbook
TargetAddr = "A" & RowNext & ":D" & _
RowNext + UBound(OutputValue, 1) - 1
ExcelWkBk.Worksheets(WkShtName). _
Range(TargetAddr).Value = OutputValue
RowNext = RowNext + 50
InxOutput = 1
End If
OutputValue(InxOutput, 1) = FolderName
OutputValue(InxOutput, 2) = .SenderName
OutputValue(InxOutput, 3) = .ReceivedTime
OutputValue(InxOutput, 4) = Url
End If
PosAnchor = InStr(PosTrailingQuote, LCase(.HtmlBody), "<a")
Loop
End If
End If
End If
End With
Next
End With
Next
ExcelWkBk.Save ' Save changes over the top of the original file.
ExcelWkBk.Close (False) ' Don't save changes
Set ExcelWkBk = Nothing ' Release resource
End Sub
我无法将我的解决方案放在一个答案中，因为它超出了大小限制。 这是我回答的第 2 部分。 它包含第 1 部分中描述的代码块。请先阅读第 1 部分。
Option Explicit
Public Type MAPIFolderDtl
NameParent As String
Folder As MAPIFolder
NumMail As Long
NumMeet As Long
End Type
' -----------------------------------------------------------------------
' ## Insert other routines here
' -----------------------------------------------------------------------
Sub FindInterestingFolders(ByRef IntFolderList() As MAPIFolderDtl, _
WantMail As Boolean, WantMeet As Boolean, _
NameSep As String, _
ParamArray NameFullList() As Variant)
' * Return a list of interesting folders.
' * To be interesting a folder must be named or be a subfolder of a named
' folder and contain mail and or meeting items if wanted.
' * Note: a top level folder cannot be returned as interesting because such
' folders are not of type MAPIFolder.
' * IntFolders() The list of interesting folders. See Type MAPIFolderDtl for
' contents.
' * WantMail True if a folder containing mail items is to be classified
' as interesting.
' * WantMeet True if a folder containing meeting items is to be classified
' as interesting.
' * NameSep SubFolder Names in NameList are of the form:
' "Personal Folders" & NameSep & "Inbox"
' NameSep can be any character not used in a folder name. It
' appears any character could be used in a folder name including
' punctuation characters. If in doubt, try Tab.
' * NameFullList One or more full names of folders which might themselves be
' interesting or might be the parent an interesting folders.
Dim InxTLFList() As Long
Dim InxIFLCrnt As Long
Dim InxNFLCrnt As Long
Dim InxTLFCrnt As Variant
Dim NameFullCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim Pos As Long
Dim TopLvlFolderList As Folders
InxIFLCrnt = 0 ' Nothing in IntFolderList()
Set TopLvlFolderList = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders
For InxNFLCrnt = LBound(NameFullList) To UBound(NameFullList)
NameFullCrnt = NameFullList(InxNFLCrnt) ' Get next name
' Split name into first part and the rest. For Example,
' "Personal Folders|NHSIC|Commisioning" will be split into:
' NamePartFirst: Personal Folders
' NamePartRest: NHSIC|Commissioning
Pos = InStr(1, NameFullCrnt, NameSep)
If Pos = 0 Then
NamePartFirst = NameFullCrnt
NamePartRest = ""
Else
NamePartFirst = Mid(NameFullCrnt, 1, Pos - 1)
NamePartRest = Mid(NameFullCrnt, Pos + 1)
End If
' Create list of indices into TopLvlFolderList in
' ascending sequence by folder name
Call SimpleSortFolders(TopLvlFolderList, InxTLFList)
' NamePartFirst should be the name of a top level
' folder or empty. Ignore if it is not.
For Each InxTLFCrnt In InxTLFList
If NamePartFirst = "" Or _
TopLvlFolderList.Item(InxTLFCrnt).Name = NamePartFirst Then
' All subfolders are a different type so they
' are handled by FindInterestingSubFolder
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, _
"", TopLvlFolderList.Item(InxTLFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End If
Next
Next
If InxIFLCrnt = 0 Then
' No folders found
ReDim IntFolderList(0 To 0)
Else
ReDim Preserve IntFolderList(1 To InxIFLCrnt) ' Discard unused entries
'For InxIFLCrnt = 1 To UBound(IntFolderList)
' Debug.Print IntFolderList(InxIFLCrnt).NameParent & "|" & _
' IntFolderList(InxIFLCrnt).Folder.Name & " " & _
' IntFolderList(InxIFLCrnt).NumMail & " " & _
' IntFolderList(InxIFLCrnt).NumMeet
'Next
End If
End Sub
Sub FindInterestingSubFolders(ByRef IntFolderList() As MAPIFolderDtl, _
InxIFLCrnt As Long, NameParent As String, _
MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, NameSep As String, _
NameChild As String)
' * NameFull = ""
' MAPIFolderCrnt and all its subfolders are potentially of interest
' * NameFull <> ""
' Look further down hierarchy for subfolders of potential interest
' This routine can be called repeately by a parent routine to explore different parts
' of the folder hierarchy. It calls itself recursively to work down the hierarchy.
' IntFolderList ' Array of interesting folders.
' InxIFLCrnt ' On the first call, InxIFLCrnt will be zero and the state of
' IntFolderList will be undefined.
' NameParent ' ... Grandparent & NameSep & Parent
' MAPIFolderCrnt ' The current folder that is to be explored.
' WantMail ' True if a folder has to contain mail to be interesting
' WantMeet ' True if a folder has to contain meeting items to be interesting
' NameSep ' The name separator character
' NameChild ' Suppose the original path was xxx|yyy|zzz. For each recurse down
' a name is removed from the start of NameChild and added to the end
' of NameParent. When NameChild is blank, the target folder has
' been reached.
Dim InxSFList() As Long
Dim InxSFCrnt As Variant
Dim NameCrnt As String
Dim NamePartFirst As String
Dim NamePartRest As String
Dim NumMail As Long
Dim NumMeet As Long
Dim Pos As Long
Pos = InStr(1, NameChild, NameSep)
If Pos = 0 Then
NamePartFirst = NameChild
NamePartRest = ""
Else
NamePartFirst = Mid(NameChild, 1, Pos - 1)
NamePartRest = Mid(NameChild, Pos + 1)
End If
If NameParent = "" Then
' This folder has no parent. It cannot be interesting.
NameCrnt = MAPIFolderCrnt.Name
Else
' This folder has a parent. It could be interesting.
NameCrnt = NameParent & NameSep & MAPIFolderCrnt.Name
If NamePartFirst = "" Then
If FolderHasRequiredItems(MAPIFolderCrnt, WantMail, _
WantMeet, NumMail, NumMeet) Then
' Debug.Print NameCrnt & " interesting"
If InxIFLCrnt = 0 Then
ReDim IntFolderList(1 To 100)
End If
InxIFLCrnt = InxIFLCrnt + 1
If InxIFLCrnt > UBound(IntFolderList) Then
ReDim Preserve IntFolderList(1 To 100 + UBound(IntFolderList))
End If
IntFolderList(InxIFLCrnt).NameParent = NameParent
Set IntFolderList(InxIFLCrnt).Folder = MAPIFolderCrnt
IntFolderList(InxIFLCrnt).NumMail = NumMail
IntFolderList(InxIFLCrnt).NumMeet = NumMeet
Else
' Debug.Print NameCrnt & " not interesting"
End If
End If
End If
If MAPIFolderCrnt.Folders.Count = 0 Then
' No subfolders
Else
Call SimpleSortMAPIFolders(MAPIFolderCrnt, InxSFList)
For Each InxSFCrnt In InxSFList
If NamePartFirst = "" Or _
MAPIFolderCrnt.Folders(InxSFCrnt).Name = NamePartFirst Then
Select Case NamePartFirst
' Ignore folders that can cause problems
Case "Sync Issues"
Case "RSS Feeds"
Case "Public Folders"
Case Else
' Recurse to analyse next level down
Call FindInterestingSubFolders(IntFolderList, InxIFLCrnt, NameCrnt, _
MAPIFolderCrnt.Folders(InxSFCrnt), WantMail, _
WantMeet, NameSep, NamePartRest)
End Select
End If
Next
End If
End Sub
Function FolderHasRequiredItems(MAPIFolderCrnt As MAPIFolder, WantMail As Boolean, _
WantMeet As Boolean, ByRef NumMail As Long, _
ByRef NumMeet As Long) As Boolean
' Return True if folder is interested. That is: at least one of the following is true:
' WantMail = True And NumMail > 0
' WantMeet = True And NumMeet > 0
' Values for NumMail and NumMeet are set whether or not the folder is interesting
Dim FolderItem As Object
Dim FolderItemClass As Long
Dim InxItemCrnt As Long
NumMail = 0
NumMeet = 0
' Count mail and meeting items in folder
For InxItemCrnt = 1 To MAPIFolderCrnt.Items.Count
Set FolderItem = MAPIFolderCrnt.Items.Item(InxItemCrnt)
' This seems to avoid syncronisation errors
FolderItemClass = 0
On Error Resume Next
FolderItemClass = FolderItem.Class
On Error GoTo 0
Select Case FolderItemClass
Case olMail
NumMail = NumMail + 1
Case olMeetingResponsePositive, olMeetingRequest, olMeetingCancellation, _
olMeetingResponseNegative, olMeetingResponseTentative
NumMeet = NumMeet + 1
End Select
Next
If WantMail And NumMail > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
If WantMeet And NumMeet > 0 Then
FolderHasRequiredItems = True
Exit Function
End If
FolderHasRequiredItems = False
End Function
Sub SimpleSortMAPIFolders(MAPIFolderList As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into MAPIFolderList sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
Debug.Assert MAPIFolderList.Folders.Count >= 1 ' Must be at least one folder
ReDim InxArray(1 To MAPIFolderList.Folders.Count) ' One entry per folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
' Each repeat of the loop movest the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If MAPIFolderList.Folders(InxArray(InxIACrnt)).Name > _
MAPIFolderList.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub
伙计们，我正在使用 codetwo Outlook 导出器来执行此任务。我不知何故偶然发现了它。谢谢Marc nd Expfresh！你的解决方案很棒，但我在尝试之前找到了另一种方法。这个论坛有乐于助人的人真是太好了。仅适用于面临相同问题的人：使用 CODETWO Outlook 导出器。- 做这项工作。问候 - 艾迪