Wie man 'at' durch @ ersetzt
-
27-10-2019 - |
Frage
Ich habe ungefähr 17.000 E -Mails, die Bestellungen, Nachrichten, Kontakte usw. enthalten, 11 Jahre zurück.
Die E -Mail -Adressen der Benutzer wurden schlecht verschlüsselt, um Crawler und Spam zu stoppen, indem sie das ändern @
entweder *@*
oder 'at'
.
Ich versuche, eine von Kommas getrennte Liste zu erstellen, um eine Datenbank unserer Benutzer zu erstellen.
Der Code funktioniert mit dem Schreiben der Datei und dem Schleifen der Ordner, denn wenn ich die E -Mail -Adresse der Absender in die Datei schreibe, in der ich gerade den Körper der E -Mail verwende, druckt er einwandfrei.
Das Problem ist das, das Replace
S ändert sich nicht *at*
usw. an @
.
- Warum nicht, warum nicht?
- Gibt es einen besseren Weg für mich, dies als Ganzes zu tun?
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
Lösung
Ich habe einen Riss darüber gemacht, um E -Mails wie dieses Beispiel zu extrahieren, in dem die drei E -Mail -Adressen in Yellow in der folgenden Beispielnachricht in eine CSV -Datei herausgenommen werden
- Alle gültigen E -Mails werden in eine CSV -Datei geschrieben
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- Dieser Code scannt alle E -Mails in einem Ordner genannt
temp
unterInbox
Ich habe Ihren rekursiven Teil des Tests und der Einfachheit ausgestrahlt - Es gibt vier Saitenmanipulationen
- Diese Linie wandelt alle Leerzeichen nicht auf normale Räume um
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(unwahrscheinlich, aber es geschah in meinen Tests) - REGEX1 konvertiert jeden "oder"bei"usw. in"@"
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- Regex2 konvertiert jeden "Punkt" oder "Punkt"usw. in". "
"(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
- Regex3 konvertiert eines von "<" ">" oder ":" in "" "
.Pattern = "[<:>]"
- Regex4 -Auszüge irgendein Gültige E -Mail aus dem E -MailBody
Alle gültigen E -Mails werden mit der CSV -Datei mit geschrieben
objTF.writeline objRegM
Code unten
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
Andere Tipps
Was ist mit einem Regex (regulärer Ausdruck)?
Etwas wie:
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
Ersetzen Sie einfach den Regexp durch alle Fälle, die Sie erhalten könnten.
Sehen http://www.regular-expressions.info/ Weitere Tipps und Infos.