Function ExtractAndDissectMail$(txt$, Optional dissection As Byte = 0)
'*********************************************************************************
'Vérifie s'il y a une adresse mail dans une chaîne et, le cas échéant, l'extrait
'Magic_Doctor
'*********************************************************************************
'- txt : une chaîne de caractères contenant ou pas une adresse courriel (ex : Corresponding Author: Sr. Diego Zorro diegozorro@macho-uno.justiciapopular.mx THE BEST TO SAVE THE WORLD)
'- dissection : si 0 (ou omis) --> extraction de l'adresse mail dans son intégralité............ diegozorro@macho-uno.justiciapopular.mx
' si 1 --> extraction uniquement de l'identifiant................................. diegozorro
' si 2 --> extraction uniquement du sous-domaine, du domaine et de l'extension.... macho-uno.justiciapopular.mx
' si 3 --> extraction uniquement du sous-domaine.................................. macho-uno
' si 4 --> extraction uniquement du domaine de 2ème niveau........................ justiciapopular
' si 5 --> extraction uniquement du domaine de 1er niveau (extension ou TLD)...... mx
Dim regEx As Object, courriel$, PieceOfString$, strTab$(), nb As Byte
Set regEx = CreateObject("VBScript.RegExp")
txt = LCase(txt) 'met toute la chaîne en minuscules au cas où un maladroit aurait mis des majuscules dans l'adresse mail
With regEx
.Pattern = "[a-z0-9._%+-]+@[a-z0-9.-]+\.[a-z]{2,}" 'adresse mail complète
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
If regEx.test(txt) Then 'le "Pattern" est bien retrouvé dans la chaîne
courriel = regEx.Execute(txt)(0)
ExtractAndDissectMail = courriel 'extraction de l'adresse courriel dans son intégralité (diegozorro@macho-uno.justiciapopular.mx)
Else 'le "Pattern" n'est pas retrouvé dans la chaîne
ExtractAndDissectMail = "Not matched": Exit Function
End If
If dissection = 1 Then
regEx.Pattern = "[a-z0-9._%+-]+" 'identifiant
ExtractAndDissectMail = regEx.Execute(courriel)(0) 'extraction de l'identifiant de l'adresse courriel (diegozorro)
ElseIf dissection = 2 Then
regEx.Pattern = "[a-z0-9._%+-]+@" 'identifiant + @
PieceOfString = regEx.Replace(courriel, "") 'l'adresse mail est débarrassée de son identifiant et du @
ExtractAndDissectMail = PieceOfString 'extraction du domaine dans son intégralité (macho-uno.justiciapopular.mx)
ElseIf dissection = 3 Then
regEx.Pattern = "[a-z0-9._%+-]+@" 'identifiant + @
PieceOfString = regEx.Replace(courriel, "") 'l'adresse mail est débarrassée de son identifiant et du @
strTab = Split(PieceOfString, "."): nb = UBound(strTab()) 'nombre de "." dans la chaîne "PieceOfString"
If nb = 1 Then 'il n'y a pas de sous-domaine
PieceOfString = "Not matched"
Else 'il y a un sous-domaine
regEx.Pattern = "(.*)\.(.*)\.(.*)" 'structure de la chaîne "PieceOfString" (3 mots séparés par un ".")
PieceOfString = regEx.Replace(PieceOfString, "$1") 'on prend le 1er mot
End If
ExtractAndDissectMail = PieceOfString
ElseIf dissection = 4 Then
regEx.Pattern = "[a-z0-9._%+-]+@" 'identifiant + @
PieceOfString = regEx.Replace(courriel, "") 'l'adresse mail est débarrassée de son identifiant et du @
strTab = Split(PieceOfString, "."): nb = UBound(strTab()) 'nombre de "." dans la chaîne "PieceOfString"
If nb = 1 Then 'il n'y a pas de sous-domaine
regEx.Pattern = "(.*)\.(.*)" 'structure de la chaîne "PieceOfString" (2 mots séparés par un ".")
PieceOfString = regEx.Replace(PieceOfString, "$1") 'on prend le 1er mot
Else 'il y a un sous-domaine
regEx.Pattern = "(.*)\.(.*)\.(.*)" 'structure de la chaîne (3 mots séparés par un ".")
PieceOfString = regEx.Replace(PieceOfString, "$2") 'on prend le 2ème mot
End If
ExtractAndDissectMail = PieceOfString
ElseIf dissection = 5 Then
regEx.Pattern = "[a-z0-9._%+-]+@[a-z0-9.-]+\." 'adresse mail complète sans l'extension
ExtractAndDissectMail = regEx.Replace(courriel, "") 'extraction du domaine de 1er niveau ou extension (spécial, national, générique) de l'adresse courriel (mx)
End If
End Function