「at」を @に置き換える方法

StackOverflow https://stackoverflow.com/questions/8361142

  •  27-10-2019
  •  | 
  •  

質問

注文、ニュース、連絡先などを含む約17kのメールが11年前に戻ります。

ユーザーの電子メールアドレスは、クローラーとスパムを変更することで、ひどく暗号化されています。 @ どちらか *@* また 'at'.

ユーザーのデータベースを作成するために、コンマ分離リストを作成しようとしています。

コードは、ファイルの書き込みとフォルダーのループで動作します。これは、電子メールの本文を現在使用しているファイルに送信者のメールアドレスを書くと、正常に印刷されるためです。

問題は、です ReplaceSは変わっていません *at* など @.

  1. まず第一に、なぜですか？
  2. 私がこれを全体として行うためのより良い方法はありますか？
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ファイルに取り出します。

  1. 有効な電子メールはすべてCSVファイルに書き込まれます Set objTF = objFSO.createtextfile("c:\myemail.csv")
  2. このコードスキャン 全て 呼ばれるフォルダー内の電子メール temp 下 Inbox テストとシンプルさの再帰部分を切り取ります
  3. 4つの文字列操作があります
  4. このラインは、印刷なしの空間スペースを通常のスペースに変換します strMsgBody = Replace(strMsgBody, Chr(160), Chr(32) （ありそうもないが、それは私のテストで起こった）
  5. regex1は「at」または「」を変換しますで「@」への「」 "(\s+at\s+|'at'|<at>|\*at\*|at)"
  6. regex2は「ドット」または「」を変換しますドット「Into」など。 "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
  7. regex3は「<」 ""> "または"： "に" "に変換されます" .Pattern = "[<:>]"
  8. regex4抽出物 どれか 電子メールボディからの有効な電子メール

  9. 有効な電子メールはすべてCSVファイルに書き込まれます objTF.writeline objRegM

    enter image description here

以下のコード

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/ その他のヒントとインフォ。

ライセンス： CC-BY-SA と 帰属
所属していません StackOverflow
scroll top