KutoolsforOffice — 一套方案，五大工具。事半功倍。

Outlook：如何从一封邮件中提取所有网址

作者Sun修改日期

如果一封邮件中包含上百个网址需要提取，逐一复制粘贴无疑十分繁琐。本文将为您介绍一段可快速批量提取邮件中所有网址的 VBA 代码。

VBA：将一封邮件中的所有网址提取到纯文本

VBA：将多封邮件中的所有网址提取到 Excel 文件

Office Tab - 让 Microsoft Office 支持标签式编辑和浏览，工作轻松无忧
立即解锁 Kutools for Outlook，畅享 100 多项功能，永久不限次数使用
通过这些高级功能提升您的 Outlook 2024 - 2010 或 Outlook 365. 尽享 100+ 项强大功能，让您的邮箱体验全面升级！

VBA：将一封邮件中的所有网址提取到纯文本

 

1. 选中需要提取网址的邮件后，按下 Alt+F11 键，即可打开 Microsoft Visual Basic for Applications 窗口。

2. 单击插入 > 模块，即可新建一个空白模块，然后将以下代码复制粘贴到该模块中。

VBA：如何将邮件中的所有网址提取为纯文本？

Sub ExportUrlToTextFileFromEmail()
'UpdatebyExtendoffice20220413
  Dim xMail As Outlook.MailItem
  Dim xRegExp As RegExp
  Dim xMatchCollection As MatchCollection
  Dim xMatch As Match
  Dim xUrl As String, xSubject As String, xFileName As String
  Dim xFs As FileSystemObject
  Dim xTextFile As Object
  Dim i As Integer
  Dim InvalidArr
  On Error Resume Next
  If Application.ActiveWindow.Class = olInspector Then
    Set xMail = ActiveInspector.CurrentItem
  ElseIf Application.ActiveWindow.Class = olExplorer Then
    Set xMail = ActiveExplorer.Selection.Item(1)
  End If
  Set xRegExp = New RegExp
  With xRegExp
    .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
    .Global = True
    .IgnoreCase = True
  End With
  If xRegExp.test(xMail.Body) Then
    InvalidArr = Array("/", "\", "*", ":", Chr(34), "?", "<", ">", "|")
    xSubject = xMail.Subject
    For i = 0 To UBound(InvalidArr)
      xSubject = VBA.Replace(xSubject, InvalidArr(i), "")
    Next i
    xFileName = "C:\Users\Public\Downloads\" & xSubject & ".txt"
    Set xFs = CreateObject("Scripting.FileSystemObject")
    Set xTextFile = xFs.CreateTextFile(xFileName, True)
    xTextFile.WriteLine ("Export URLs:" & vbCrLf)
    Set xMatchCollection = xRegExp.Execute(xMail.Body)
    i = 0
    For Each xMatch In xMatchCollection
      xUrl = xMatch.SubMatches(0)
      i = i + 1
      xTextFile.WriteLine (i & ". " & xUrl & vbCrLf)
    Next
    xTextFile.Close
    Set xTextFile = Nothing
    Set xMatchCollection = Nothing
    Set xFs = Nothing
    Set xFolderItem = CreateObject("Shell.Application").NameSpace(0).ParseName(xFileName)
    xFolderItem.InvokeVerbEx ("open")
    Set xFolderItem = Nothing
  End If
  Set xRegExp = Nothing
End Sub

在此代码中，将以邮件标题为名，在 C:\Users\Public\Downloads 路径下创建一个新的纯文本文件，您可根据需要自行修改路径。

从一封邮件中提取所有网址的步骤

3. 单击工具 > 引用，打开 引用-Project 1 对话框，勾选 Microsoft VBScript Regular Expressions 5.5 复选框。最后，单击确定。

从一封邮件中提取所有网址的步骤
从一封邮件中提取所有网址的步骤

4. 按下 F5 键或单击运行按钮即可运行代码，随后会弹出一个纯文本窗口，所有网址已被提取并显示其中。

从一封邮件中提取所有网址的步骤
从一封邮件中提取所有网址的步骤

注意：如果您使用的是 Outlook 2010 或 Outlook 365，请在第 3 步同时勾选 Windows Script Host Object Model 复选框，然后点击确定。

VBA：将多封邮件中的所有网址提取到 Excel 文件

 

如果您希望将多封选中邮件中的所有网址提取到 Excel 文件中，可以使用以下 VBA 代码。

1. 选择要提取网址的邮件，然后按 Alt+F11 键，打开 Microsoft Visual Basic for Applications 窗口。

2. 单击插入> 模块 以创建新空白模块，然后将以下代码复制粘贴到模块中。

VBA：将多封邮件中的所有网址提取到 Excel 文件

'UpdatebyExtendoffice20220414
Dim xExcel As Excel.Application
Dim xExcelWb As Excel.Workbook
Dim xExcelWs As Excel.Worksheet

Sub ExportAllUrlsToExcelFromMultipleEmails()
  Dim xMail As MailItem
  Dim xSelection As Selection
  Dim xWordDoc As Word.Document
  Dim xHyperlink As Word.Hyperlink
  On Error Resume Next
  Set xSelection = Outlook.Application.ActiveExplorer.Selection
  If (xSelection Is Nothing) Then Exit Sub
  Set xExcel = CreateObject("Excel.Application")
  Set xExcelWb = xExcel.Workbooks.Add
  Set xExcelWs = xExcelWb.Sheets(1)
  xExcelWb.Activate
  With xExcelWs
    .Range("A1") = "Subject"
    .Range("B1") = "DisplayText"
    .Range("C1") = "Link"
  End With
  With xExcelWs.Range("A1", "C1").Font
    .Bold = True
    .Size = 12
  End With
  For Each xMail In xSelection
    Set xWordDoc = xMail.GetInspector.WordEditor
    If xWordDoc.Hyperlinks.Count > 0 Then
      For Each xHyperlink In xWordDoc.Hyperlinks
          Call ExportToExcelFile(xMail, xHyperlink)
      Next
    End If
  Next
  xExcelWs.Columns("A:C").AutoFit
  xExcel.Visible = True
End Sub

Sub ExportToExcelFile(curMail As MailItem, curHyperlink As Word.Hyperlink)
  Dim xRow As Integer
  xRow = xExcelWs.Range("A" & xExcelWs.Rows.Count).End(xlUp).Row + 1
  With xExcelWs
    .Cells(xRow, 1) = curMail.Subject
    .Cells(xRow, 2) = curHyperlink.TextToDisplay
    .Cells(xRow, 3) = curHyperlink.Address
  End With
End Sub

此代码可提取所有超链接及其对应的显示文本和邮件标题。

从一封邮件中提取所有网址的步骤

3. 单击工具 > 引用，打开 引用–Project 1 对话框，勾选 Microsoft Excel 16.0 对象库 和 Microsoft Word 16.0 对象库 复选框。最后，单击确定。

从一封邮件中提取所有网址的步骤
从一封邮件中提取所有网址的步骤

4. 将光标置于 VBA 代码内后，按 F5 键或单击运行按钮即可运行代码，随后会弹出工作簿，并自动将所有网址提取到其中，您可将其保存到指定文件夹。

从一封邮件中提取所有网址的步骤

注意：以上所有 VBA 代码均可提取各种类型的超链接。

最佳办公效率工具

体验全新 Kutools for Outlook，畅享 100+ 强大功能！立即点击下载，不容错过！

🤖KUTOOLS AI：采用先进 AI 技术，轻松处理邮件，涵盖回复、摘要、优化、扩展、翻译及撰写等功能。

📧 邮件自动化：自动答复（支持 POP 和 IMAP）/定时发送邮件/发送邮件时按规则自动抄送密送/自动转发（高级规则）/自动添加称呼/自动将多收件人邮件拆分为单独信息……

📨 邮件管理：撤回邮件/按主题等条件拦截诈骗邮件/删除重复邮件/高级搜索/整合文件夹……

📁 附件增强：批量保存/批量分离/批量压缩/自动保存/自动拆离/自动压缩……

🌟 界面魔法：😊更多美观时尚表情/重要邮件到达时提醒您/最小化 Outlook 而不是直接关闭……

👍 一键精彩功能：带附件全部答复/反钓鱼邮件/🕘显示发送者当前时间时区……

👩🏼‍🤝‍👩🏻 联系人与日历：批量从选定邮件中提取添加联系人/将联系人组拆分为个人组/移除生日提醒……

在您的首选语言中畅享 Kutools —— 支持英语、西班牙语、德语、法语、中文等 40 多种语言！

一键解锁 Kutools for Outlook，告别等待，立即下载，让效率倍增！

kutools for outlook features1kutools for outlook features2

🚀 一键下载 — 即可获取全部 Office 加载项

强烈推荐：Kutools for Office（5 合 1）

一键下载五个安装包，即可同时获得 Kutools for Excel、Outlook、Word、PowerPoint 和 Office Tab Pro。立即点击下载！

  • ✅ 一键便捷：只需一次操作，即可下载全部五个安装包。
  • 🚀 轻松应对各类 Office 任务：随时按需安装所需插件，助您高效办公，不容错过！
  • 🧰 包含：Kutools for Excel / Kutools for Outlook / Kutools for Word / Office Tab Pro / Kutools for PowerPoint