跳至主要内容

Kutools for Office — 一套工具,五种功能。事半功倍。

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

Author Sun Last modified

如果一封邮件包含需要提取到文本文件中的数百个网址,逐一手动复制粘贴将是一项繁琐的任务。本教程介绍可以快速从邮件中提取所有网址的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 中,您可以根据需要进行更改。

steps on extracting all URLs from one email

3. 单击 工具 > 引用 打开 引用 – Project 1 对话框,勾选 Microsoft VBScript Regular Expressions 5.5 复选框,然后单击 确定

steps on extracting all URLs from one email
steps on extracting all URLs from one email

4. 按 F5 键或单击 运行 按钮运行代码,此时会弹出一个文本文件,其中已提取了所有网址。

steps on extracting all URLs from one email
steps on extracting all URLs from one email

注意:如果您是 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

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

steps on extracting all URLs from one email

3. 单击 工具 > 引用 打开 引用 – Project 1 对话框,勾选 Microsoft Excel 16.0 Object Library Microsoft Word 16.0 Object Library 复选框,然后单击 确定

steps on extracting all URLs from one email
steps on extracting all URLs from one email

4. 然后将光标置于VBA代码内,按 F5 键或单击 运行 按钮运行代码,此时会弹出一个工作簿,所有网址都已提取到其中,您可以将其保存到文件夹中。

steps on extracting all URLs from one email

注意:以上所有的VBA代码均提取所有类型的超链接。


最佳 Office 办公效率工具

最新消息:Kutools for Outlook 推出免费版!

体验全新 Kutools for Outlook,超过100 种强大功能!立即点击下载!

🤖 Kutools AI 采用先进的 AI 技术,轻松处理邮件,包括答复、总结、优化、扩展、翻译和撰写邮件。

📧 邮箱自动化自动答复(支持 POP 和 IMAP) /计划发送邮件 /发送邮件时按规则自动抄送密送 / 自动转发(高级规则) / 自动添加问候语 / 自动将多收件人的邮件分割为单独邮件 ...

📨 邮件管理撤回邮件 / 按主题及其他条件阻止欺诈邮件 / 删除重复邮件 / 高级搜索 / 整合文件夹 ...

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

🌟 界面魔法😊更多美观酷炫的表情 /重要邮件到达时提醒 / 最小化 Outlook 而非关闭 ...

👍 一键高效操作带附件全部答复 / 防钓鱼邮件 / 🕘显示发件人时区 ...

👩🏼‍🤝‍👩🏻 联系人与日历批量添加选中邮件中的联系人 / 分割联系人组为单独的组 / 移除生日提醒 ...

可根据您偏好选择 Kutools 使用语言——支持英语、西班牙语、德语、法语、中文及40 多种其他语言!

只需点击一下即可立即激活 Kutools for Outlook。无需等待,立即下载,提升工作效率!

kutools for outlook features1 kutools for outlook features2

🚀 一键下载——获取所有 Office 插件

强烈推荐:Kutools for Office(五合一)

一键下载五个安装包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