質問
注文、ニュース、連絡先などを含む約17kのメールが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
解決
これに亀裂を取り、以下のこのサンプルなどのメールを抽出し、以下のサンプルメッセージの3つの電子メールアドレスをCSVファイルに取り出します。
- 有効な電子メールはすべてCSVファイルに書き込まれます
Set objTF = objFSO.createtextfile("c:\myemail.csv")
- このコードスキャン 全て 呼ばれるフォルダー内の電子メール
temp
下Inbox
テストとシンプルさの再帰部分を切り取ります - 4つの文字列操作があります
- このラインは、印刷なしの空間スペースを通常のスペースに変換します
strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)
(ありそうもないが、それは私のテストで起こった) - regex1は「at」または「」を変換しますで「@」への「」
"(\s+at\s+|'at'|<at>|\*at\*|at)"
- regex2は「ドット」または「」を変換しますドット「Into」など。
"(\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
regexpを取得する可能性のあるすべてのケースに置き換えるだけです。
見る http://www. Regual-Expressions.info/ その他のヒントとインフォ。
所属していません StackOverflow