Outlook：如何從一封電子郵件中提取所有網址

作者孫修改日期2024-09-03

若一封電子郵件中包含數百個需提取為純文字的網址，逐一複製貼上將極其耗時費力。本教學將介紹一段 VBA 程式碼，助您快速從電子郵件中提取所有網址。

將一封電子郵件中的網址提取至純文本的 VBA

將多封電子郵件中的網址提取至 Excel 檔案的 VBA

Office Tab －在 Microsoft Office 中啟用分頁編輯與瀏覽功能，讓工作輕鬆自如

閱讀 Office Tab 的功能詳情下載 Office Tab

立即解鎖 Kutools for Outlook，永久享有超過 100 項功能的無限使用權

提升您的郵件處理效率！運用人工智慧技術，讓您快速回覆郵件、撰寫新郵件、翻譯訊息，輕鬆高效完成各項操作！
透過規則自動化寄送郵件，搭配自動抄送密送，自動轉發自動寄送自動答覆（外出中），無需 Exchange 伺服器即可實現……
取得貼心提醒功能，例如答覆的郵件為 BCC 時提示當您位於密件副本（BCC）清單中卻回覆全部收件人時，以及遺漏附件提醒針對遺忘的附件發出提示……
透過以下功能提升郵件處理效率：附帶附件回覆（全部），自動於簽名檔或主旨中加入問候語或日期與時間，一次回覆多封郵件……
透過以下功能簡化郵件處理流程：撤回郵件，附件工具（全部壓縮、自動保存全部……），刪除重複，以及快速報告……

透過這些進階功能強化您的 Outlook 2024 - 2010 或 Outlook 365. 盡享 100+ 強大功能，全面提升您的郵件體驗！

閱讀 Kutools for Outlook 的所有功能立即下載

將一封電子郵件中的網址提取至純文本的 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. 點擊工具＞參考，開啟 參考 – 專案 1 對話方塊，勾選 Microsoft VBScript Regular Expressions 5.5 核取方塊，再點擊確定。

4. 按下 F5 鍵或點擊執行按鈕以執行程式碼，隨即彈出一個純文字視窗，其中已提取所有網址。

注意：若您使用的是 Outlook 2010 與 Outlook 365，請於步驟 3 中同時勾選「Windows 指令稿主機物件模型」核取方塊，然後點擊確定。

將多封電子郵件中的網址提取至 Excel 檔案的 VBA

若您希望將多封已選取電子郵件中的網址提取至 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. 點擊工具＞參考，開啟 參考 – 專案 1 對話方塊後，勾選 Microsoft Excel 16.0 物件庫 與 Microsoft Word 16.0 物件庫 核取方塊，再點擊確定。

4. 接著將游標置於 VBA 程式碼內，按下 F5 鍵或點擊執行按鈕以執行程式碼，此時將自動彈出一個活頁簿，其中已提取所有網址，您可立即儲存至指定資料夾，輕鬆備份不遺漏！

注意：上述所有 VBA 均可提取各類型超連結。

最佳 Office 生產力工具

體驗全新 Kutools for Outlook，內含 100+ 項超強功能！立即點擊下載！

🤖KUTOOLS AI：運用先進 AI 技術，輕鬆處理電子郵件——無論是回覆、摘要、優化、擴充、翻譯還是撰寫郵件，通通一鍵搞定！

📧 郵件自動化：自動答覆（支援 POP 與 IMAP）／預約寄送郵件／寄信時依規則自動抄送密送／自動轉發（高級規則）／自動加入問候語／自動將多收件人郵件拆分為個別訊息……

📨 郵件管理：撤回郵件／依主旨等條件封鎖詐騙郵件／刪除重複郵件／高級搜尋／整合文件夾……

📁 附件專業版：批次儲存／批次解除附加／批次壓縮／自動保存／自動拆離／自動壓縮……

👍 一鍵奇蹟：帶附件全部答復／防釣魚郵件／🕘顯示發送者當前時間時區……

👩🏼‍🤝‍👩🏻 聯絡人與行事曆：從選取的郵件中批次新增聯絡人／將聯繫人組拆分為個別群組／移除生日提醒……

用您的慣用語言暢享 Kutools — 完整支援英文、西班牙文、德文、法文、中文等 40 多種語言！

立即一鍵解鎖 Kutools for Outlook！別再等待，馬上下載，全面提升工作效率！

Kutools for Outlook 功能列表立即下載前往購買

🚀 一鍵下載 — 立即取得所有 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

關於此套件 ⬇ 下載套件 💳 購買套件