Outlook: Как да извлечете всички URL адреси от един имейл

Ако един имейл съдържа стотици URL адреси, които трябва да бъдат извлечени в текстов файл, копирането и поставянето им един по един ще бъде досадна работа. Този урок представя VBA, които могат бързо да извличат всички URL адреси от имейл.

VBA за извличане на URL адреси от един имейл в текстов файл

VBA за извличане на URL адреси от множество имейли към Excel файл

VBA за извличане на URL адреси от един имейл в текстов файл

1. Изберете имейл, чиито URL адреси искате да извлечете, и натиснете Друг + F11 ключове за активиране Microsoft Visual Basic за приложения прозорец.

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 5.5 квадратче за отметка. Щракнете върху OK.

4. Натиснете F5 клавиша или щракване бягане бутон за изпълнение на кода, сега изскача текстов файл и всички URL адреси са извлечени в него.

Забележка: ако сте потребители на Outlook 2010 и Outlook 365, моля, поставете отметка и в квадратчето Windows Script Host Object Model в стъпка 3. След това щракнете върху OK.

VBA за извличане на URL адреси от множество имейли към Excel файл

Ако искате да извлечете URL адреси от множество избрани имейли към Excel файл, кодът VBA по-долу може да ви помогне.

1. Изберете имейл, чиито URL адреси искате да извлечете, и натиснете Друг + F11 ключове за активиране Microsoft Visual Basic за приложения прозорец.

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 извличат всички видове хипервръзки.

---

Най-добрите инструменти за продуктивност в офиса

Kutools за Outlook - Над 100 мощни функции, за да заредите вашия Outlook

🤖 AI Mail Assistant: Незабавни професионални имейли с AI магия - с едно щракване до гениални отговори, перфектен тон, многоезично владеене. Трансформирайте имейла без усилие! ...

📧 Автоматизиране на имейли: Извън офиса (налично за POP и IMAP)  /  График за изпращане на имейли  /  Автоматично CC/BCC по правила при изпращане на имейл  /  Автоматично пренасочване (разширени правила)   /  Автоматично добавяне на поздрав   /  Автоматично разделяне на имейлите с множество получатели на отделни съобщения ...

📨 Управление на Email: Лесно извикване на имейли  /  Блокиране на измамни имейли по теми и други  /  Изтриване на дублирани имейли  /  подробно търсене  /  Консолидиране на папки ...

📁 Прикачени файлове Pro: Пакетно запазване  /  Партидно отделяне  /  Партиден компрес  /  Автоматично запазване   /  Автоматично отделяне  /  Автоматично компресиране ...

🌟 Магия на интерфейса: 😊 Още красиви и готини емотикони   /  Увеличете продуктивността на Outlook с изгледи с раздели  /  Минимизирайте Outlook, вместо да затваряте ...

???? Чудеса с едно кликване: Отговорете на всички с входящи прикачени файлове  /   Антифишинг имейли  /  🕘Показване на часовата зона на подателя ...

👩🏼‍🤝‍👩🏻 Контакти и календар: Групово добавяне на контакти от избрани имейли  /  Разделете група контакти на отделни групи  /  Премахнете напомнянията за рожден ден ...

Над 100 Характеристики Очаквайте вашето проучване! Щракнете тук, за да откриете повече.

Вижте повече       Безплатно сваляне      покупка