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 Instrumente > 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 Instrumente > 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.

---

Cele mai bune instrumente de productivitate de birou

Kutools pentru Outlook - Peste 100 de funcții puternice pentru a vă supraalimenta Outlook

🤖 AI Mail Assistant: E-mailuri profesionale instantanee cu magie AI--un singur clic pentru răspunsuri geniale, ton perfect, stăpânire în mai multe limbi. Transformați e-mailurile fără efort! ...

📧 Automatizare e-mail: În afara biroului (disponibil pentru POP și IMAP)  /  Programați trimiterea de e-mailuri  /  CC/BCC automat după reguli la trimiterea e-mailului  /  Redirecționare automată (Reguli avansate)   /  Adăugare automată felicitare   /  Împărțiți automat e-mailurile cu mai mulți destinatari în mesaje individuale ...

📨 Managementul e-mail: Amintește-ți cu ușurință e-mailurile  /  Blocați e-mailurile înșelătorii de către subiecți și alții  /  Ștergeți e-mailurile duplicate  /  Cautare Avansata  /  Consolidați foldere ...

📁 Atașamente Pro: Salvați în serie  /  Detașare lot  /  Compresă în loturi  /  Salvare automata   /  Detașare automată  /  Comprimare automată ...

🌟 Magia interfeței: 😊Mai multe emoji drăguțe și cool   /  Îmbunătățiți-vă productivitatea Outlook cu vizualizările cu file  /  Minimizați Outlook în loc să închideți ...

???? Minuni cu un singur clic: Răspundeți tuturor cu atașamentele primite  /   E-mailuri anti-phishing  /  🕘Afișați fusul orar al expeditorului ...

👩🏼‍🤝‍👩🏻 Contacte și calendar: Adăugați în lot contacte din e-mailurile selectate  /  Împărțiți un grup de contact în grupuri individuale  /  Eliminați mementouri de ziua de naștere ...

Peste 100 Caracteristici Așteaptă explorarea ta! Click aici pentru a descoperi mai multe.

Citeste mai mult       Descărcare gratuită      Cumpărare