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

あるメールに数百のURLが含まれており、それらをテキストファイルに抽出する必要がある場合、1つずつコピーして貼り付けるのは非常に面倒な作業です。このチュートリアルでは、メールからすべてのURLを迅速に抽出できるVBAを紹介します。

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

複数のメールからExcelファイルにURLを抽出するための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 Script Host Object Model」のチェックボックスもオンにしてください。その後、「OK」をクリックします。

複数のメールからExcelファイルにURLを抽出するための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 Object Library」と「 Microsoft Word 16.0 Object Library」のチェックボックスをオンにします。「OK」をクリックします。

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

注意: 上記のすべてのVBAは、すべての種類のハイパーリンクを抽出します。

---

最高のオフィス生産性ツール

速報：Kutools for Outlook が無料版をリリース！

新しくなった Kutools for Outlook を100以上の素晴らしい機能とともに体験してください！今すぐダウンロード！

🤖 Kutools AI : 高度なAI技術を活用し、メールの返信、要約、最適化、拡張、翻訳、作成を効率良くこなします。

📧 メール自動化: 自動返信（POPとIMAPに対応） / メール送信のスケジュール設定 /送信時にルールで自動 CC/BCC / 高度なルールによる自動転送 / 挨拶文を自動追加 / 複数宛先のメールを自動で個別のメールに分割 ...

📨 メール管理: メールの取り消し / 件名やその他の条件で迷惑メールをブロック / 重複したメールの削除 / 高度な検索 / フォルダーを整理 ...

📁 添付ファイルPro: 一括保存 / 一括切り離し / 一括圧縮 / 自動保存 / 自動的に切り離す / 自動圧縮 ...

🌟 インターフェースマジック: 😊もっとキレイで楽しい絵文字 /重要なメールの到着をお知らせ / Outlookを閉じずに最小化 ...

👍 ワンクリック便利機能: 全員に【Attachment】付きで返信 /迷惑メール対策 / 🕘送信者のタイムゾーン表示 ...

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

お好みの言語で Kutools をご利用いただけます ― 英語、スペイン語、ドイツ語、フランス語、中国語など40以上をサポート！

Kutools for Outlook はワンクリックですぐにアンロックできます。今すぐダウンロードして効率をアップしましょう！

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