配信不能メール本文からテキスト文字列を抽出してExcelに送信

Question

Outlook VBAに関するヘルプが必要です。

個々の配送不能メール本文から電子メールアドレスを抽出するために、Outlookにマクロを書き込もうとしています。

配信に失敗したメールは何百もありますので、手動でコピーして貼り付けるよりも自動的に抽出できる方が良いでしょう。

メールの本文は以下のようになります：

----------------------------メール---- ------------------------

配達は、これらの受信者またはグループに失敗しました：

XXXX@XXXXXX.XXX（XXXX @ XXXXXX.XXX）

...不要情報...

へ：XXXX@XXXXXX.XXX

...不要情報...

------------------------ ---- Email -----------------------------

私は完全にOutlookのVBA初心者ですこれは、Excelシートを開いた私のテストメールの受信トレイ、上で完璧に勤務し、すべてのPAを記載されている

Sub Test() 
    Dim myFolder As MAPIFolder 
    Dim Item As Outlook.MailItem 'MailItem 
    Dim xlApp As Object 'Excel.Application 
    Dim xlWB As Object 'Excel.Workbook 
    Dim xlSheet As Object 'Excel.Worksheet 
    Dim Lines() As String 
    Dim i As Integer, x As Integer, P As Integer 
    Dim myItem As Variant 
    Dim subjectOfEmail As String 
    Dim bodyOfEmail As String 

'Try access to excel 
    On Error Resume Next 
    Set xlApp = GetObject(, "Excel.Application") 
    If xlApp Is Nothing Then 
    Set xlApp = CreateObject("Excel.Application") 
    xlApp.Application.Visible = True 
    If xlApp Is Nothing Then 
     MsgBox "Excel is not accessable" 
     Exit Sub 
    End If 
    End If 
    On Error GoTo 0 

'Add a new workbook 
    Set xlWB = xlApp.Workbooks.Add 
    xlApp.Application.Visible = True 
    Set xlSheet = xlWB.ActiveSheet 
    Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
    For Each myItem In myFolder.Items 
    subjectOfEmail = myItem.Subject 
    bodyOfEmail = myItem.Body 

'Search for Undeliverable email 
    If bodyOfEmail Like "*Delivery*" & "*failed*" And indexOfEmail Like "*Undeliverable*" Then 
     x = x + 1 
'Extract email address from email body 
     Lines = Split(myItem.Body, vbCrLf) 
     For i = 0 To UBound(Lines) 
     P = InStr(1, Lines(i), "@", vbTextCompare) 
     Q = InStr(1, Lines(i), "(", vbTextCompare) 
     If P > 0 Then 
      xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) 'extract the email address 
      Exit For 
     End If 
     Next 
    End If 
    Next 
End Sub 

：検索と多くのトレイルの多くの後、私は最終的に以下のコードを思い付い目標の電子メールの中の事実上の電子メールアドレス。

しかし、このコードを私の仕事の電子メールアカウントで実行すると、それは私には何も分かりませんでした。それから、「配送不能」の電子メールを読むのに問題があることがわかりました。奇妙なことは、それを実行したたびに、伝えられない電子メールの1つが繁体字に変わり、全く読むことができません。

以下のように：

格浴㹬格慥㹤਍洼瑥⁡瑨灴攭畱癩∽潃瑮湥⵴祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰：猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨⁳慦汩摥琠桴獥⁥敲楣楰湥獴漠⁲牧畯獰㰺是湯㹴⼼㹢⼼㹰਍昼湯⁴潣潬

このコードは私のテスト電子メールでのみ転送配信不能メール、上の作品のように私は感じています受信トレイ。しかし、それはマイクロソフトの見通しから送られたオリジナルの配信不能な電子メールから読み取ることは決してありませんし、これらの電子メールを1文字ずつ漢字に変換しました。

私は彼らが失敗した配信メールのOutlookのいくつかのバグだように見えた、それについてGoogleで検索。あなたの誰かがこれを修正する方法を知っていますか？または、コードを改善する方法はありますか？私は何かを変えたいと思っています。

Answer 1

はイライラし、数日後、私は最終的にOutlookのNDRのいずれかの制限を心配したり、まったくVBAを使用することはありませんする必要はありませんはるかに簡単な解決策、...私が何をしたか

があるが思いつきました：

1. はtxtファイルを開いて、「.TXT」ファイル
2. オープンExcelなどのOutlookで
3. 保存し、すべての配信不能メールを選択し、 『区切り』を選択し、で区切り文字として 『タブ』を選択「テキストインポートウィザード」
4. フィルタアウト「：を」とのコラムAは、その後、列B上のすべての電子メールアドレスを取得します

がために君たちをありがとう...これはVBAよりもはるかに簡単であると信じてすることはできませんあなたの助け！ちょうど本当に扱うことはできません "Outlook NDRは、ワークステーションの非常に多くの制限と、読み取り可能な文字に回して、これは参考になるかもしれないと思う！

Answer 2

Outlookオブジェクトモデル（Outlook 2013 abd 2016）のReportItem.Bodyプロパティに問題があります。OutlookSpyに表示されます：NDRメッセージを選択し、アイテムボタンをクリックしてBodyプロパティを選択します。歪んだ。レポートアイテムがOOMにタッチした後、それよりもさらに悪いことに、Outlookは、プレビューペインに同じジャンクが表示されます。

レポートテキストは、OutlookSpyのIMessageボタンをクリックしてGetRecipientTableタブに移動し、さまざまなMAPI受信者プロパティに格納されます。問題はReportItemオブジェクトが受信者コレクションを公開していないことです。あなたはまた、より多様なNDRのプロパティを抽出するためにRDOReportItem.Recipientsコレクションを使用することができます

set oItem = Application.ActiveExplorer.Selection(1) 
set oSession = CreateObject("Redemption.RDOSession") 
oSession.MAPIOBJECT = Application.Session.MAPIOBJECT 
set rItem = oSession.GetRDOObjectFromOutlookObject(oItem) 
MsgBox rItem.ReportText 

：そのRDOReportItem .ReportTextプロパティは、この問題を持っていない - この問題を回避するには、拡張MAPI（C++やDelphi）またはRedemption（任意の言語）を使用するかであります受信者テーブル。