Come sostituire 'AT' con @
-
27-10-2019 - |
Domanda
Ho circa 17K e -mail contenenti ordini, notizie, contatti ecc. Rischendo 11 anni.
Gli indirizzi e -mail degli utenti sono stati crittografati con scarse per fermare i crawler e lo spam modificando il @
per entrambi *@*
o 'at'
.
Sto cercando di creare un elenco separato da virgola per creare un database dei nostri utenti.
Il codice funziona con la scrittura del file e il loop delle cartelle perché se scrivo l'indirizzo e -mail dei mittenti al file in cui sto attualmente usando il corpo dell'e -mail, sta stampa bene.
Il problema è, il Replace
S non sta cambiando *at*
ecc @
.
- Prima di tutto, perché no?
- C'è un modo migliore per me di farlo nel suo insieme?
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
Soluzione
Ho preso una crepa per estrarre e -mail come questo campione di seguito che eliminerà i tre indirizzi e -mail in giallo nel messaggio di esempio di seguito a un file CSV
- Eventuali e -mail valide sono scritte su un file CSV
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- Questo codice scansionò tutto e -mail in una cartella chiamata
temp
sottoInbox
Ho ritagliato la tua porzione ricorsiva di test e semplicità - Ci sono quattro manipolazioni di stringhe
- Questa linea converte qualsiasi spazi vuoti non stampati in spazi normali
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(improbabile ma è successo nei miei test) - Regex1 converte qualsiasi "at" o "a"ecc. in"@"
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- Regex2 converte qualsiasi "punto" o "punto"ecc. in". "
"(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
- Regex3 converte una qualsiasi di "<" ">" o ":" in ""
.Pattern = "[<:>]"
- Estratti regex4 qualunque Email valida dall'emailbody
Eventuali e -mail valide vengono scritte nel file CSV utilizzando
objTF.writeline objRegM
Codice di seguito
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
Altri suggerimenti
Che ne dici di usare un regex (espressione regolare)?
Qualcosa di simile a:
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
Basta sostituire il regexp con ogni casi che potresti ottenere.
Vedere http://www.regular-expressions.info/ Per ulteriori suggerimenti e INFOS.