Как заменить 'на' с @
-
27-10-2019 - |
Вопрос
У меня около 17 тысяч писем, содержащих заказы, новости, контакты и т. Д. Уходя на 11 лет.
Адреса электронной почты пользователей были поражены, чтобы остановить сканеров и спам, изменив @
либо *@*
или же 'at'
.
Я пытаюсь создать отдельный список запятой для создания базы данных наших пользователей.
Код работает с написанием файла и зацикливанием папок, потому что, если я напишу адрес электронной почты отправителя в файл, где я в настоящее время использую тело электронного письма, он печатает нормально.
Проблема в том, что Replace
S не меняется *at*
и т.д. @
.
- Прежде всего, почему бы и нет?
- Есть ли лучший способ сделать это в целом?
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
Решение
Я взял на это трещину, чтобы извлечь электронные письма, такие как этот пример ниже, который выберет три адреса электронной почты в желтом цвете в примере сообщения ниже в файл CSV
- Любые электронные письма Valids записаны в файл CSV
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- Этот код сканирует все Электронные письма в папке под названием
temp
подInbox
Я вырезал вашу рекурсивную часть тестирования и простоты - Есть четыре строковых манипуляции
- Эта линия преобразует любые не печатные пустые пространства в обычные пространства
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(маловероятно, но это произошло в моем тестировании) - Regex1 преобразует любой "AT" или "в"и т.д. в"@"
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- Regex2 преобразует любую «точку» или »точка"и т. Д. В".
"(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
- Regex3 преобразует любое из "<" ">" или ":" в ""
.Pattern = "[<:>]"
- Выдержки REGEX4 Любые Действительное электронное письмо от тела электронной почты
Любые действительные электронные письма записываются в файл CSV с использованием
objTF.writeline objRegM
Код ниже
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
Другие советы
А как насчет использования регулярного выражения (регулярное выражение)?
Что-то типа:
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
Просто замените регуляцию на каждые случаи, которые вы можете получить.
Видеть http://www.regular-expressions.info/ Для получения дополнительных советов и инфо.