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

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

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

VBA：從一封電子郵件提取網址至純文本

VBA：從多封電子郵件提取網址至 Excel 檔案

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 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. 點選工具＞ 參考項目，開啟 參考項目 – 專案 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

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