从Outlook电子邮件正文复制超链接，并导出到Excel或记事本

这是我正在寻找的：

我在Outlook中有20个不同的文件夹，每个都有相同的电子邮件正文结构和格式。 每个电子邮件正文有3至7个超链接我想要出口这些超链接之一（其容易识别，因为它有一个相同的开始/一个特定的单词内 – 不要紧，如果我们出口这个特定的超链接或全部因为我们可以稍后在Excel中编辑它们）。

我希望这些超链接被导出到excel表单元格中

我现在做什么：

我正在使用剪贴板去发送每封电子邮件。 右键单击复制链接，然后粘贴到记事本或Excel中。

让我知道如果你们有什么build议。 这将真正简化我的工作..当然还有其他可能寻找类似解决scheme的人。

问候，

AA

Answer 1

你可以导出为ex​​cel，但在复制到excel之前，

– >你必须select有超链接的电子邮件。 通过select电子邮件righclick并select发送到一注 。

– > 单注将打开。 翻阅One-note的本节（右侧）中的页面标签。 select所有的邮件（页面），然后右键 – >复制 。

1. 现在您可以将复制的项目粘贴到记事本中 。
2. 现在你可以将记事本中的所有内容复制到excel中。

3. 你可以find或应用filter， filter-> textfilter->包含所需的单词或短语（其容易识别，因为它具有相同的起始/特定的单词） 。

4. 如果你直接从onenote复制到excel意味着所有的表格，附件和其他内容都将被粘贴，那么将很难过滤或find所需的超链接。

5. 因为你说20个文件夹是不可能的文件夹发送到onenote ，你需要打开20文件夹，然后你可以select任何数量的电子邮件在每个文件夹。

🙂

Answer 2

我不能在一个单一的答案我的解决scheme，因为它超过了大小的限制。 这是我答案的第二部分。 它包含第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 

Answer 3

我不能在一个单一的答案我的解决scheme，因为它超过了大小的限制。 这是我答案的第一部分。 我已经移动了一个代码块到第二个答案。

这是一个VBA解决scheme。 你给一个好的规格，所以我相信这将接近你的要求。 我希望我已经包含足够的意见，让你作出最后的调整。 如果没有，问。

这第一个代码块包含我为我写的子例程。 他们执行我认为有用的任务。 他们包括评论，但他们写的评论提醒我，他们不帮助别人理解他们。 我为你写的macros使用它们，并解释如何使用它们。 现在我build议你不要担心这些子程序如何做。

我也许应该警告你，我很less在自己的macros中使用error handlingfunction，因为我不希望它们优雅地失败。 我希望他们停止对问题的陈述，以便我能理解和纠正原因。

在Outlook中，打开VBA编辑器，插入一个模块并将第一个代码块复制到该模块中。 您还需要单击Tools然后单击References 。 是“Microsoft Excel nn.n对象库”靠近顶部，并打勾？ 如果未勾选，则必须滚动完成列表，find该参考并勾选它。 “nn.n”的值将取决于您使用的Excel版本。 只有当您安装了多个版本的Excel时，才可以select。

继续下面的代码。

这段代码移到了答案的第二部分。

下面是四个macros。 前三个是教程，第四个是我的解决scheme。

如果您的Outlook安装像我的一样，您将拥有个人文件夹 ， 存档文件夹和其他文件夹 。 在个人文件夹中，您将拥有标准文件夹收件箱 ， 发件箱等。 您可能已经在这些标准文件夹中添加了自己的文件夹，或者您可能已经将它们添加到个人文件夹 。 在我自己的系统上，我有各种各样的文件夹，包括！家庭和！托尼 。 每个包含子文件夹和其中的一个子文件夹！Tony是Amazon 。

在第一个macros中，你最需要理解的语句是：

  Call FindInterestingFolders(FolderList, True, False, "|", _ "Personal Folders|!Family", "Personal Folders|!Tony|Amazon") 

FindInterestingFolders是上面代码中包含的子例程之一。 这个语句的第二行用我觉得方便的风格来指定我提到的两个文件夹的名字。 macrosFindInterestingFolders返回有关这两个文件夹及其可能具有的任何子文件夹或子子文件夹的信息。 您必须将这两个名称replace为您要search的文件夹。 如果20个文件夹都在一个父项下，则可以指定该单项父项。 如果20个文件夹分散，则可能需要指定所有20个文件夹的名称。

第一个macros输出到立即窗口FindInterestingFoldersfind的所有文件夹的名称。 在我的系统上输出：

 Personal Folders|!Family|Chloe & Euan Personal Folders|!Family|Geoff Personal Folders|!Family|Lucy & Mark Personal Folders|!Tony|Amazon Personal Folders|!Tony|Amazon|Trueshopping Ltd 

将这个macros复制到你上面创build的模块中，并使用它，直到你创build了一个你想要search的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调用复制到以下macros中。

macros2build立在macros1上。它用Html主体search感兴趣的邮件文件夹。 对于每个Html主体，它search定位标记并输出到即时窗口中的每个标记和接下来的58个字符。 立即窗口只显示最后200行左右，所以你只能看到输出的底部。 这没关系; 这个想法是让你先看看这个macros能看到什么。 在我的系统上，输出结束：

  Tony Dallimore 13/02/2012 15:42:00 RE: Product details enquiry from Amazon customer ... <A HREF="mailto:[e-mail]">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 

标题行包含邮件项目的发件人，收件时间和主题。

将这个macros添加到模块中，将FindInterestingFolders的修改调用复制到我的调用顶部并运行它。 几乎立即，你会被警告，一个macros正在访问电子邮件。 您将不得不允许macros继续，并select一段时间继续。 我假设你有安全级别设置为标准的中等。 如果你已经设置了不同的东西，你会得到不同的select。

继续下面的代码。

 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 

我再次希望这很容易。 我不确定下一个macros是多么有用。 这是我发展的一个步骤，但它不包含任何重要性，也不在最后的macros观范围内。 这可能是值得您研究的，因为最终的macros观将会有macros2的两个重要变化。

Macro 3所做的是从锚标记中提取URL并放弃那些启动“mailto：”的URL。 Html允许更多的变化比我所允许的，因为我从来没有看到一个电子邮件，利用这种灵活性。 如果您的电子邮件与我所期望的不同，则可能需要增强我的代码。 您只需要从每封电子邮件中获得一个url，以便您可以添加代码来丢弃其他url。

再次，将这个macros添加到模块中，将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 

对于最后的macros，我在其中一个工作簿中创build了一个工作表，用于开发答案。

在最后一个macros中，你会发现这个声明：

  Const WkBkPathFile As String = "C:\DataArea\Play\Combined 10 V02.xls" 

您需要将其replace为工作簿的path和文件名。

你也会发现这个声明：

  Const WkShtName As String = "URLs" 

我已经使用工作表url 。 我build议你先创build一个像我的工作表。 一旦你有最后的macros工作，你可以适应你的要求。

我在工作表中有四列：文件夹名称，发件人名称，接收时间和URL。 第三列保存完整的date和时间，但我格式化它只显示一个简短的date。 你的问题没有什么build议你想要这些额外的列。 我认为这是值得展示你可以做什么，并留下你删除代码，如果它不感兴趣。

我认为你需要用接收时间做一些事情。 除非您将已处理的电子邮件从20个文件夹中移出，否则每次运行macros都将重新添加一组完整的URL。 有许多技术不再处理电子邮件。 例如，您可以将用户类别添加到已处理的电子邮件中。 不过，我怀疑最简单的方法是：

• 将一个隐藏的工作表添加到工作簿。
• 将此工作表的单元格A1设置为“最新处理的电子邮件”，并将B1设置为2000年1月1日。
• 添加到放弃不感兴趣的电子邮件的代码，在这个date/时间之后的接收时间的testing。
• logging任何处理的电子邮件的最新收到时间。
• 将任何处理过的电子邮件的最新接收时间写入隐藏工作表的单元格B1。

我在最后的macros中包含了大量的注释，解释了如何积累数据并将其写入工作表，所以我不在这里重复一遍。 我祝你好运，并在开始时重复说明，如果有什么不清楚的地方。

再一次，将这个macros添加到模块中，将修改后的FindInterestingFolders调用复制到我的调用顶部。 这一次，您还必须在运行macros之前更新一个或两个常量语句。

 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 

Answer 4

我正在使用codetwo outlook exporter来执行这个任务。 我以某种方式偶然发现了它..谢谢Marc nd Expfresh！ 你的解决scheme是伟大的，但我还没有尝试过之前find另一种方式..这是非常好的，这个论坛有帮助的人。 只针对面临同样问题的人们：使用CODETWOoutlook出口商。 – 做这个工作。 问候 – 阿迪