Cómo reemplazar 'en' con @
-
27-10-2019 - |
Pregunta
Tengo alrededor de 17k correos electrónicos que contienen pedidos, noticias, contactos, etc. que se remontan a 11 años.
Las direcciones de correo electrónico de los usuarios se han encriptado de manera luminada para detener los rastreadores y el spam cambiando el @
a cualquiera *@*
o 'at'
.
Estoy tratando de crear una lista separada por comas para crear una base de datos de nuestros usuarios.
El código funciona con la escritura del archivo y enojar las carpetas porque si escribo la dirección de correo electrónico de los remitentes al archivo donde actualmente estoy usando el cuerpo del correo electrónico, se imprime bien.
El problema es, el Replace
s no está cambiando *at*
etc. @
.
- En primer lugar, ¿por qué no?
- ¿Hay una mejor manera de hacer esto en general?
Private Sub Form_Load()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
Dim fldName As String
fldName = "TEST"
' Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
' Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
'Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
RecurseFolders fldName, objFolder
Next objFolder
End Sub
Public Sub RecurseFolders(targetFolder As String, currentFolder As MAPIFolder)
If currentFolder.Name = targetFolder Then
GetEmails currentFolder
Else
Dim objFolder As MAPIFolder
If currentFolder.Folders.Count > 0 Then
For Each objFolder In currentFolder.Folders
RecurseFolders targetFolder, objFolder
Next
End If
End If
End Sub
Sub WriteToATextFile(e As String)
MyFile = "c:\" & "emailist.txt"
'set and open file for output
fnum = FreeFile()
Open MyFile For Append As fnum
Print #fnum, e; ","
Close #fnum
End Sub
Sub GetEmails(folder As MAPIFolder)
Dim objMail As MailItem
' Read through all the items
For i = 1 To folder.Items.Count
Set objMail = folder.Items(i)
GetEmail objMail.Body
Next i
End Sub
Sub GetEmail(s As String)
Dim txt = s
Do Until InStr(txt, "@") <= 0
Dim tleft As Integer
Dim tright As Integer
Dim start As Integer
Dim text As String
Dim email As String
text = Replace(text, " at ", "@", VbCompareMethod.vbTextCompare)
text = Replace(text, "'at'", "@", VbCompareMethod.vbTextCompare)
text = Replace(text, "*at*", "@", VbCompareMethod.vbTextCompare)
text = Replace(text, "*at*", "@", VbCompareMethod.vbTextCompare)
text = Replace(text, "<", " ", VbCompareMethod.vbTextCompare)
text = Replace(text, ">", " ", VbCompareMethod.vbTextCompare)
text = Replace(text, ":", " ", VbCompareMethod.vbTextCompare)
'one two ab@bd.com one two
tleft = InStr(text, "@") '11
WriteToATextFile Str(tleft)
WriteToATextFile Str(Len(text))
start = InStrRev(text, " ", Len(text) - tleft)
'WriteToATextFile Str(start)
'WriteToATextFile Str(Len(text))
'start = Len(text) - tleft
text = left(text, start)
'ab@bd.com one two
tright = InStr(text, " ") '9
email = left(text, tright)
WriteToATextFile email
text = right(text, Len(text) - Len(email))
GetEmail txt
Loop
End Sub
Solución
He tomado una grieta en esto para extraer correos electrónicos como esta muestra a continuación que eliminará las tres direcciones de correo electrónico en amarillo en el mensaje de muestra a continuación a un archivo CSV
- Los correos electrónicos válidos se escriben en un archivo CSV
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- Este código escanea todos correos electrónicos en una carpeta llamado
temp
por debajoInbox
Corté su parte recursiva de pruebas y simplicidad - Hay cuatro manipulaciones de cadenas
- Esta línea convierte cualquier espacio en blanco que no imprima en espacios normales
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(poco probable pero sucedió en mis pruebas) - Regex1 convierte cualquier "at" o "a"etc en"@"
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- Regex2 convierte cualquier "punto" o "punto"etc en". "
"(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
- Regex3 convierte cualquiera de "<" ">" o ":" en ""
.Pattern = "[<:>]"
- Extractos de regex4 ningún correo electrónico válido del cuerpo de correo electrónico
Cualquier correo electrónico válido se escribe en el archivo CSV utilizando
objTF.writeline objRegM
Código a continuación
Public Test()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim strfld As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Dim objFSO As Object
Dim oMailItem As MailItem
Dim objTF As Object
Dim strMsgBody As String
Set objRegex = CreateObject("vbscript.regexp")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("c:\myemail.csv")
With objRegex
.Global = True
.MultiLine = True
.ignorecase = True
strfld = "temp"
'Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
'Pick up the Inbox
Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder.Folders(strfld)
For Each oMailItem In objFolder.Items
strMsgBody = oMailItem.Body
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32))
.Pattern = "(\s+at\s+|'at'|<at>|\*at\*|at)"
strMsgBody = .Replace(strMsgBody, "@")
.Pattern = "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
strMsgBody = .Replace(strMsgBody, ".")
.Pattern = "[<:>]"
strMsgBody = .Replace(strMsgBody, vbNullString)
.Pattern = "[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}"
If .Test(strMsgBody) Then
Set objRegMC = .Execute(strMsgBody)
For Each objRegM In objRegMC
objTF.writeline objRegM
Next
End If
Next
End With
objTF.Close
End Sub
Otros consejos
¿Qué hay de usar una regex (expresión regular)?
Algo como:
Public Function ReplaceAT(ByVal sInput as String)
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = "( at |'at'|<at>)"
End With
ReplaceAT = RegEx.Replace(sInput, "@")
Set RegEx = Nothing
End Function
Simplemente reemplace el regexp con todos los casos que pueda obtener.
Ver http://www.regular-expressions.info/ Para más consejos e infos.