Outlook: как извлечь все URL-адреса из одного письма

Если письмо содержит сотни URL-адресов, которые нужно извлечь в текстовый файл, копировать и вставлять каждый вручную превратится в утомительную рутину. В этом руководстве представлены макросы VBA, позволяющие мгновенно извлечь все URL-адреса из письма.

Макрос VBA для извлечения URL-адресов из одного письма в Текстовый файл

Макрос VBA для извлечения URL-адресов из нескольких писем в файл Excel

Макрос VBA для извлечения URL-адресов из одного письма в Текстовый файл

1. Выберите письмо, из которого нужно извлечь URL-адреса, и нажмите клавиши Alt+F11, чтобы открыть окно Microsoft Visual Basic for Applications.

2. Нажмите Вставить > Модуль, чтобы создать новый пустой модуль, затем скопируйте и вставьте приведённый ниже код в этот модуль.

Макрос VBA: извлеките все 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 и нажмите кнопку ОК.

4. Нажмите клавишу F5 или кнопку Выполнить, чтобы запустить код — и перед вами появится текстовый файл со всеми извлечёнными URL-адресами.

Примечание: если вы используете Outlook 2010 или Outlook 365, обязательно установите флажок «Windows Script Host Object Model» на шаге 3, а затем нажмите «ОК».

Макрос VBA для извлечения URL-адресов из нескольких писем в файл Excel

Если вам нужно извлечь 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 и нажмите кнопку ОК.

4. Затем поместите курсор внутрь кода VBA и нажмите клавишу F5 или кнопку Выполнить, чтобы запустить код. После этого откроется книга Excel со всеми извлечёнными URL-адресами — её можно будет сразу сохранить в нужную папку.

Примечание: все приведённые выше макросы VBA извлекают гиперссылки любого типа.

---

Лучшие инструменты для повышения продуктивности в Office

Оцените совершенно новый Kutools для Outlook с 100+ потрясающими функциями!Нажмите, чтобы скачать прямо сейчас!

🤖KUTOOLS AI:Использует передовые технологии ИИ для удобной работы с электронной почтой: ответы, составление резюме, оптимизация, расширение, перевод и создание писем.

📧Автоматизация работы с электронной почтой: Автоответ (доступен для POP и IMAP) / Планирование отправки писем / Авто Копия/Скрытая копия по правилам при отправке писем / Автоматическое перенаправление (расширенное правило) / Автоматическое добавление приветствия / Автоматическое разделение писем с несколькими получателями на отдельные сообщения…

📨Управление электронной почтой: Отозвать письмо / Блокировка спама по теме и другим признакам / Удаление дубликатов писем / Расширенный поиск / Организация папок…

📁Продвинутая работа с вложениями: Пакетное сохранение / Пакетное отсоединение / Пакетное сжатие / Автосохранение / Автоматическое отсоединение / Автоматическое сжатие…

🌟Волшебство интерфейса: 😊Еще больше красивых и стильных эмодзи / Напоминание о важных входящих письмах / Сворачивание Outlook вместо закрытия…

👍Чудеса одним щелчком: Ответить всем с вложениями / Защита от фишинговых писем / 🕘Отображение часового пояса: текущее время отправителя…

👩🏼‍🤝‍👩🏻Контакты и календарь: Пакетное добавление контактов из выбранных писем / Разделение группы контактов на отдельные группы / Удаление напоминания о дне рождения…

Используйте Kutools на вашем любимом языке — поддержка английского, испанского, немецкого, французского, китайского и более чем 40 других языков!

Мгновенно получите доступ к Kutools для Outlook одним щелчком! Не теряйте время — скачайте прямо сейчас и повысьте свою эффективность!

Список функций Kutools для Outlook      Скачать сейчас      Перейти к покупке

🚀 Скачать одним щелчком — Получите все надстройки для Office

Настоятельно рекомендуется: Kutools for Office (5 в 1)

Скачайте одним щелчком пять установщиковсразу —Kutools для Excel, Outlook, Word, PowerPointи Office Tab Pro.Нажмите, чтобы скачать прямо сейчас!

• ✅Удобство одним щелчком: Скачайте все пять установочных пакетов за одно действие.
• 🚀Готовы к любой задаче в Office: устанавливайте нужные надстройки именно тогда, когда они вам понадобятся.
• 🧰Входит в комплект: Kutools для Excel / Kutools для Outlook / Kutools для Word / Office Tab Pro / Kutools for PowerPoint

О пакете⬇ Скачать пакет💳 Приобрести пакет