Outlook：1 通のメールからすべての URL を抽出する方法

メールに数百もの URL が含まれていて、それらをテキストファイルに抽出しなければならないとき、1 つずつコピーアンドペーストするのは非常に手間がかかります。このチュートリアルでは、メールからすべての URL を瞬時に抽出できる VBA コードをご紹介します。

1 通のメールから URL をテキストファイルに抽出する VBA

複数のメールから URL をExcel ファイルに抽出する VBA

1 通のメールから URL をテキストファイルに抽出する VBA

1。URL を抽出したいメールを選択し、Alt+F11キーを押して、Microsoft Visual Basic for Applicationsウィンドウを開きます。

2。挿入＞モジュールをクリックして、新しい空白のモジュールを作成し、以下のコードをモジュールにコピー＆ペーストしてください。

VBA：1 通のメールに含まれるすべての 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:\Users\Public\Downloads。必要に応じて変更可能です。

3。ツール > 参照設定をクリックして、参照設定 – プロジェクト1ダイアログボックスを開き、Microsoft VBScript Regular Expressions 5.5のチェックボックスをオンにしてください。OKをクリックします。

4。F5キーを押すか、実行ボタンをクリックしてコードを実行すると、すべての URL が抽出されたテキストファイルが表示されます。

注：Outlook 2010 およびOutlook 365 をご利用の場合は、手順3 で「Windows スクリプトホストオブジェクトモデル」のチェックボックスをオンにしてから、OK をクリックしてください。

複数のメールから URL をExcel ファイルに抽出する VBA

複数のメールを一括選択して URL をExcel ファイルに抽出したい場合は、以下の VBA コードが役立ちます。

1。URL を抽出したいメールを選択し、Alt+F11キーを押してMicrosoft Visual Basic for Applicationsウィンドウを開きます。

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

このコードでは、すべてのハイパーリンクとその表示テキスト、およびメールの件名を抽出します。

3。ツール > 参照設定をクリックして、参照設定 – プロジェクト1ダイアログボックスを開き、Microsoft Excel 16.0 オブジェクトライブラリとMicrosoft Word 16.0 オブジェクトライブラリのチェックボックスをオンにしてください。OKをクリックします。

4。次に、VBA コード内にカーソルを置き、F5キーを押すか、実行ボタンをクリックしてコードを実行すると、ワークブックが表示され、すべての URL が抽出されます。そのまま任意のフォルダーに保存できます。

注：上記のすべての VBA コードは、あらゆる種類のハイパーリンクを抽出します。

---

最高の Office 生産性ツール

まったく新しいKutools for Outlook を、100 以上の驚きの機能とともに体験しましょう！今すぐダウンロード！

🤖KUTOOLS AI：高度な AI 技術を活用して、メールの返信、要約、最適化、拡張、翻訳、作成など、あらゆる操作をラクラクこなします。

📧メール自動化：自動返信（POP および IMAP 対応）/メールのスケジュール送信/メール送信時にルールに基づいて自動 CC/BCC/自動転送（高度なルール）/自動で挨拶文を追加/複数の宛先を持つメールを個別のメッセージに自動分割...

📨メール管理：メールの取り消し/件名などを基準に詐欺メールをブロック/重複したメールを削除/高度な検索/フォルダーを整理...

📁添付ファイルプロ：一括保存/一括分離/一括圧縮/自動保存/自動的に切り離す/自動圧縮...

🌟インターフェースの魅力：😊さらに美しくクールな絵文字を多数収録/重要なメールが届いた際に通知/Outlook を閉じる代わりに最小化...

👍ワンクリックの驚き：全員に【Attachment】付きで返信/フィッシングメール対策/🕘送信者の現在時刻ゾーンを表示...

👩🏼‍🤝‍👩🏻連絡先とカレンダー：選択したメールから連絡先を追加を一括登録/連絡先グループを個別のグループに分割/誕生日のリマインダーを削除...

Kutools はお好みの言語でお使いいただけます！英語、スペイン語、ドイツ語、フランス語、中国語をはじめ、40 以上の言語をサポートしています！

ワンクリックでKutools for Outlook の機能を即解放！今すぐダウンロードして、効率を飛躍的にアップさせましょう！

Kutools for Outlook の機能一覧      今すぐダウンロード      購入ページへ

🚀 ワンクリックダウンロード — Office アドインをすべて入手

強く推奨：Kutools for Office（5-in-1）

ワンクリックで5 つのインストーラーを 一括ダウンロード！ ―Kutools for Excel、Outlook、Word、PowerPointおよびOffice Tab Pro。今すぐダウンロード！

• ✅ワンクリックで簡単操作：5 つのセットアップパッケージをたった1 回のクリックで一括ダウンロードできます。
• 🚀どんな Office 作業にも対応可能：必要なときに、必要なアドインをすぐインストールできます。
• 🧰含まれるもの：Kutools for Excel / Kutools for Outlook / Kutools for Word / Office Tab Pro / Kutools for PowerPoint

スイートについて⬇ スイートをダウンロード💳 スイートを購入