以下是我要找的内容：
我在outlook中有20个不同的文件夹，每个文件夹都有相同的电子邮件正文结构和格式。 每个电子邮件正文都有3到7个超链接 我想导出其中一个超链接（它很容易识别，因为它有相同的起始/一个特定的单词 - 如果我们导出这个特定的超链接或所有这些都没关系，因为我们以后可以在excel中编辑它们）。
我希望将这些超链接导出到Excel工作表中的单元格
我现在正在做什么：
我正在使用剪贴板转到每封电子邮件。右键单击复制链接，然后粘贴到记事本或Excel中。
如果你们有任何建议，请告诉我。这将真正简化我的工作......当然还有其他任何可能寻找类似解决方案的人。
的问候，
AA
答案 0 :(得分：0)
您可以导出到Excel，但在复制到Excel之前，
- ＆gt;您必须选择存在超链接的电子邮件。通过选择电子邮件righclick并选择发送到单注释。
- ＆GT; 会打开一张便条。翻阅单音符的本节（右侧）中的页面选项卡。选择所有邮件（页面）和右键单击＆gt;复制。
您可以找到或应用过滤器，过滤器 - ＆gt; textfilter-＆gt;包含所需的单词或短语（它易于识别，因为它具有相同的起点/特定单词） 。
如果您直接从 onenote 复制到excel意味着将粘贴所有表格，附件和其他表格，则很难过滤或查找所需的超链接。
因为你说20个文件夹无法将文件夹发送到 onenote ，你需要打开20个文件夹然后你可以在每个文件夹中选择任意数量的电子邮件。
:)
答案 1 :(得分：0)
我无法在一个答案中使用我的解决方案，因为它超出了大小限制。 这是我答案的第1部分。我已将一段代码移到第二个答案。
这是一个VBA解决方案。你给出了一个很好的规格，所以我相信这将接近你的要求。我希望我已经包含了足够的评论，以便您做出最终调整。如果没有，请问。
这第一段代码包含了我为我编写的子程序。他们执行我认为有用的任务。它们包括评论，但它们是写的评论，以提醒我他们不帮助其他人理解它们。我为你编写的宏使用它们，我解释了如何使用它们。目前我建议你不要担心这些子程序如何做他们所做的事情。
我或许应该警告你，我很少在我自己的宏中使用错误处理功能，因为我不希望它们优雅地失败;我希望他们停止问题陈述，以便我理解并纠正原因。
在Outlook中，打开VBA编辑器，插入模块并将第一个代码块复制到其中。您还需要点击Tools然后点击References。是＆＃34; Microsoft Excel nn.n对象库＆＃34;靠近顶部，是否勾选？如果未勾选，则必须滚动完成列表，找到此引用并勾选它。 ＆＃34; nn.n＆＃34;的价值将取决于您使用的Excel版本。只有安装了多个版本的Excel才能选择。
在代码下面继续回答。
此代码移至答案的第二部分。
以下是四个宏。前三个是教程，第四个是我的解决方案。
如果您的Outlook安装与我的一样，您将拥有文件夹个人文件夹，存档文件夹以及其他人。在个人文件夹中，您将拥有标准文件夹收件箱，发件箱等。您可能已在这些标准文件夹中添加了自己的文件夹，或者可能已将它们添加到个人文件夹。在我自己的系统上，我有各种文件夹，包括！Family 和！Tony 。每个包含子文件夹和中的一个子文件夹！Tony 是亚马逊。
在第一个宏中，您最需要理解的语句是：
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
标题行包含邮件项的发件人，ReceivedTime和主题。
将此宏添加到模块中，将修改后的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
我希望这很容易。我不确定下一个宏有多么有用。这是我开发过程中的一个步骤，但它不包含重要内容，也不包含在最终宏中。你可能值得研究它，因为最终的宏将有两个重要的变化来自Macro 2。
Macro 3的作用是从锚标记中提取URL，并丢弃那些以＆＃34; mailto：＆＃34;开头的URL。 Html允许的变化比我允许的更多，因为我从未见过利用这种灵活性的电子邮件。如果您的电子邮件与我的期望不同，您可能需要增强我的代码。您只需要每个电子邮件中的一个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。第三列保存完整的日期和时间，但我将其格式化为仅显示一个短日期。您的问题没有任何建议您想要这些额外的列。我认为值得证明你可以做什么，并且如果它没有意义，请让你删除代码。
我认为你需要对收到的时间做点什么。除非您从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 :(得分：0)
我无法在一个答案中使用我的解决方案，因为它超出了大小限制。 这是我的答案的第2部分。它包含第1部分中描述的代码块。首先阅读Part 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
答案 3 :(得分：0)
伙计我正在使用codetwo outlook exporter来执行此任务。我不知何故偶然发现它..谢谢Marc nd Expfresh！你的解决方案很棒，但我甚至在尝试之前找到了另一种方式。这个论坛很有帮助。仅针对面临同样问题的人：使用CODETWO outlook Exporter。 - 这份工作。问候 - Addy