Comment remplacer « at » avec @
-
27-10-2019 - |
Question
J'ai environ 17k courriels contenant des commandes, des nouvelles, des contacts, etc. remontant 11 ans.
Les adresses e-mail des utilisateurs ont été shoddily chiffrées pour robots d'exploration d'arrêt et le spam en changeant la @
soit *@*
ou 'at'
.
Je suis en train de créer une liste séparée par des virgules pour construire une base de données de nos utilisateurs.
Le code fonctionne avec l'écriture du fichier et en boucle les dossiers parce que si j'écris l'adresse e-mail de l'expéditeur dans le fichier où je suis actuellement en utilisant le corps de l'e-mail il imprime bien.
Le problème est, les Replace
s ne changent pas *at*
etc à @
.
- Tout d'abord, pourquoi pas?
- Y at-il une meilleure façon pour moi de faire cela dans son ensemble?
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
La solution
J'ai pris une fissure à ce aux e-mails extrait comme celui exemple ci-dessous qui prendra les trois adresses e-mail en jaune dans le message exemple ci-dessous dans un fichier csv
- Tous les e-mails de valeurs admissibles sont écrites dans un fichier csv
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- Ce scans de code tous e-mails dans un dossier appelé
temp
sousInbox
Je découper votre partie récursive de test et de simplicité - Il y a quatre manipulations de cordes
- Cette ligne convertit tous les espaces vides non impression aux espaces normaux
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(peu probable, mais il est arrivé dans mes tests) - Regex1 convertit tout "à" ou " à " etc dans "@"
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- Regex2 convertit tout "point" ou " dot " etc dans ""
"(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
- Regex3 convertit l'un des "<" ">" ou ":" dans ""
.Pattern = "[<:>]"
- extraits Regex4 tout email valide du emailbody
-
Les e-mails valides sont écrites dans le fichier csv en utilisant
objTF.writeline objRegM
code ci-dessous
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
Autres conseils
Qu'en est-il en utilisant une expression rationnelle (expression régulière)?
Quelque chose comme:
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
Il suffit de remplacer l'expression régulière avec tous les cas, vous pouvez obtenir.
Voir http://www.regular-expressions.info/ pour plus de conseils et d'infos.