跳到主要内容

Outlook:如何从一封电子邮件中提取所有 URL

作者:孙 最后修改时间:2022-04-29

如果一封电子邮件包含数百个需要提取到文本文件的 URL,那么逐个复制和粘贴将是一项繁琐的工作。 本教程介绍了可以快速从电子邮件中提取所有 URL 的 VBA。

VBA 从一封电子邮件中提取 URL 到文本文件

VBA 从多封电子邮件中提取 URL 到 Excel 文件

Office 选项卡 - 在 Microsoft Office 中启用选项卡式编辑和浏览,让工作变得轻而易举
解锁 Outlook 的 Kutools 免费 版本 立即享受超过 70 项功能,永久无限制访问
使用这些高级功能增强您的 Outlook 2021 - 2010 或 Outlook 365。享受 70 多种强大功能并提升您的电子邮件体验!

VBA 从一封电子邮件中提取 URL 到文本文件

 

1. 选择您要提取 URL 的电子邮件,然后按 其他 + F11 启用键 Microsoft Visual Basic应用程序 窗口。

2。 点击 插页 > 模块 创建一个新的空白模块,然后将以下代码复制并粘贴到模块中。

VBA:将一封电子邮件中的所有 URL 提取到文本文件中。

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:\用户\公共\下载,您可以根据需要更改它。

文档提取网址 1

3。 点击 工具 > 参考资料 启用 参考 - 项目 1 对话框,勾选 Microsoft VBScript正则表达式5.5 复选框。 请点击 OK.

文档提取网址 1

文档提取网址 1

4。 按 F5 键或单击 运行 按钮运行代码,现在会弹出一个文本文件,其中所有 URL 都已提取。

文档提取网址 1

文档提取网址 1

备注:如果您是 Outlook 2010 和 Outlook 365 的用户,请同时在步骤 3 中勾选 Windows 脚本宿主对象模型复选框。然后单击确定。


VBA 从多封电子邮件中提取 URL 到 Excel 文件

 

如果您想从多个选定的电子邮件中提取 URL 到 Excel 文件,下面的 VBA 代码可以帮助您。

1. 选择您要提取 URL 的电子邮件,然后按 其他 + F11 启用键 Microsoft Visual Basic应用程序 窗口。

2。 点击 插页 > 模块 创建一个新的空白模块,然后将以下代码复制并粘贴到模块中。

VBA:将多封电子邮件中的所有 URL 提取到 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

在此代码中,它提取所有超链接以及相应的显示文本和电子邮件主题。

文档提取网址 1

3。 点击 工具 > 参考资料 启用 参考 - 项目 1 对话框,打勾 Microsoft Excel 16.0 对象库 Microsoft Word 16.0对象库 复选框。 点击 OK.

文档提取网址 1

文档提取网址 1

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

文档提取网址 1

备注:以上所有 VBA 都提取所有类型的超链接。


最佳办公生产力工具

最新消息:Kutools for Outlook 发布 免费版本!

体验全新的 Kutools for Outlook 免费版本拥有 70 多项令人难以置信的功能,您可以永久使用! 点击立即下载!

🤖 Kutools人工智能 : 具有人工智能魔力的即时专业电子邮件——一键天才回复、完美语气、多语言掌握。轻松改变电子邮件! ...

📧 电子邮件自动化: 自动回复(适用于 POP 和 IMAP)  /  安排发送电子邮件  /  发送电子邮件时按规则自动抄送/密件抄送  /  自动转发(高级规则)   /  自动添加问候语   /  自动将多收件人电子邮件拆分为单独的消息 ...

📨 电子邮件管理: 撤回电子邮件  /  按主题和其他人阻止诈骗电子邮件  /  删除重复的电子邮件  /  高级搜索  /  合并文件夹 ...

📁 附件专业版批量保存  /  批量分离  /  批量压缩  /  自动保存   /  自动分离  /  自动压缩 ...

🌟 界面魔法: 😊更多又漂亮又酷的表情符号   /  收到重要邮件时提醒您  /  最小化 Outlook 而不是关闭 ...

👍 一键奇迹: 使用传入附件回复全部  /   反网络钓鱼电子邮件  /  🕘显示发件人的时区 ...

👩🏼‍🤝‍👩🏻 通讯录和日历: 从选定的电子邮件中批量添加联系人  /  将联系人组拆分为各个组  /  删除生日提醒 ...

只需单击一下即可立即解锁 Kutools for Outlook -永久免费. 别等了, 立即下载并提高您的效率!

kutools for outlook 功能1 kutools for outlook 功能2
 

 

 

Comments (0)
No ratings yet. Be the first to rate!
There are no comments posted here yet
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations