Outlook: Cum să extrageți toate adresele URL dintr-un singur e-mail

Dacă un e-mail conține sute de adrese URL necesare pentru a fi extrase într-un fișier text, să le copiați și să le lipiți unul câte unul va fi o muncă plictisitoare. Acest tutorial prezintă VBA care pot extrage rapid toate adresele URL dintr-un e-mail.

VBA pentru a extrage adrese URL dintr-un e-mail într-un fișier text

VBA pentru a extrage adrese URL din mai multe e-mailuri într-un fișier Excel

VBA pentru a extrage adrese URL dintr-un e-mail într-un fișier text

1. Selectați un e-mail pentru care doriți să extrageți adresele URL și apăsați Alt + F11 taste pentru activare Microsoft Visual Basic pentru aplicații fereastră.

2. clic Insera > Module pentru a crea un nou modul gol, apoi copiați și inserați codul de mai jos în modul.

VBA: extrageți toate adresele URL dintr-un e-mail într-un fișier text.

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

În acest cod, va crea un fișier text nou care este numit cu subiectul e-mailului și plasat în calea: C:\Utilizatori\Public\Descărcări, îl puteți schimba după cum aveți nevoie.

3. clic unelte > Referinte pentru a permite Referințe – Proiect 1 dialog, bifați Expresii regulate Microsoft VBScript 5.5 Caseta de bifat. Clic OK.

4. presa F5 tasta sau faceți clic Alerga butonul pentru a rula codul, acum apare un fișier text și toate adresele URL au fost extrase în el.

notițe: dacă sunteți utilizatori ai Outlook 2010 și Outlook 365, vă rugăm să bifați și caseta de selectare Windows Script Host Object Model din Pasul 3. Apoi faceți clic pe OK.

VBA pentru a extrage adrese URL din mai multe e-mailuri într-un fișier Excel

Dacă doriți să extrageți adrese URL din mai multe e-mailuri selectate într-un fișier Excel, codul VBA de mai jos vă poate ajuta.

1. Selectați un e-mail pentru care doriți să extrageți adresele URL și apăsați Alt + F11 taste pentru activare Microsoft Visual Basic pentru aplicații fereastră.

2. clic Insera > Module pentru a crea un nou modul gol, apoi copiați și inserați codul de mai jos în modul.

VBA: extrageți toate adresele URL din mai multe e-mailuri într-un fișier 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

În acest cod, extrage toate hyperlinkurile și textele de afișare corespunzătoare și subiectele e-mailului.

3. clic unelte > Referinte pentru a permite Referințe – Proiect 1 dialog, bifează Biblioteca de obiecte Microsoft Excel 16.0 și Biblioteca de obiecte Microsoft Word 16.0 casete de selectare. Clic OK.

4. Apoi plasați cursorul în codul VBA, apăsați F5 tasta sau faceți clic Alerga butonul pentru a rula codul, acum apare un registru de lucru și toate adresele URL au fost extrase în el, apoi îl puteți salva într-un folder.

notițe: toate VBA-urile de mai sus extrag toate tipurile de hyperlinkuri.

Kutools pentru Outlook - aduce 100 de caracteristici avansate în Outlook și face munca mult mai ușoară!

• Auto CC / BCC prin reguli la trimiterea e-mailului; Auto înainte Mai multe e-mailuri personalizate; Răspuns automat fără server de schimb și mai multe funcții automate ...
• Avertisment BCC - afișați mesajul când încercați să răspundeți la toate dacă adresa dvs. de e-mail se află în lista BCC; Amintiți-vă când lipsesc atașamentele, și mai multe caracteristici de reamintire ...
• Răspundeți (Toate) Cu toate atașamentele din conversația prin e-mail; Răspunde la multe e-mailuri în secunde; Adăugare automată felicitare când răspundeți; Adăugați o dată în subiect ...
• Instrumente de atașament: gestionați toate atașamentele din toate e-mailurile, Detașare automată, Comprimă toate, Redenumiți toate, Salvați toate ... Raport rapid, Numărați mesajele selectate...
• E-mailuri nedorite puternice după obicei; Eliminați e-mailurile și persoanele de contact duplicate... Vă permit să faceți mai inteligent, mai rapid și mai bine în Outlook.

Citeşte mai mult ... Descarcă acum...