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 の無料版を体験してください。70以上の素晴らしい機能が永遠に使えます！今すぐダウンロードをクリック！

🤖 Kutools AI : 高度なAI技術を使用して、メールの返信、要約、最適化、拡張、翻訳、作成を簡単に行います。

📧 メール自動化: 自動返信 (POPとIMAPで利用可能) / メール送信のスケジュール / メール送信時にルールによる自動 CC/BCC / 自動転送 (高度なルール) / 自動挨拶追加 / 複数の宛先を持つメールを個別のメールに自動的に分割...

📨 メール管理: メールの取り消し / 件名やその他によるスパムメールのブロック / 重複したメールの削除 / 高度な検索 / フォルダーを整理...

📁 添付ファイルプロ: バッチ保存 / バッチ切り離し / バッチ圧縮 / 自動保存 / 自動的に切り離す / 自動圧縮...

🌟 インターフェースマジック: 😊より美しくクールな絵文字 /重要なメールが来たときに通知 / クローズ中ではなくOutlookを最小化...

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

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

Kutools for Outlook をワンクリックで即座にアンロック。待たずに今すぐダウンロードして効率を高めましょう！

Kutools for Outlook の機能一覧 ダウンロード無料版 プロフェッショナルにアップグレード