從無法投遞的電子郵件正文中提取文本字符串到excel

我需要Outlook VBA上的一些幫助。從無法投遞的電子郵件正文中提取文本字符串到excel

我正試圖在Outlook中編寫一個宏，用於從每個單獨的undeliverables電子郵件正文中提取電子郵件地址。

有數以百計的電子郵件傳遞失敗，所以它會更好，如果他們可以自動提取比手動複製和粘貼。

電子郵件正文是這樣的：

----------------------------電子郵件---- ------------------------

傳遞失敗這些收件人或組：

[email protected]（XXXX @ XXXXXX.XXX）

...不需要信息...

要：[email protected]

...沒必要信息...

------------------------ ----電子郵件-----------------------------

我是一個完全的Outlook VBA新手，所以大量的搜索和多徑後，我終於想出了下面的代碼：

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

它完美地工作在我測試的電子郵件收件箱，開闢一個Excel工作表，並列出每個PA目標電子郵件中的特定電子郵件地址。

但是，當我在我的工作電子郵件帳戶上運行此代碼時，它並沒有給我一個東西。然後我發現它在閱讀「Undeliverables」電子郵件時遇到了麻煩，而且每次我運行它之後都會發生奇怪的事情，其中一個無法收集的電子郵件變成了繁體中文字符，根本無法讀取。

象下面這樣：

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

我喜歡這種感覺代碼的工作就只能轉發無法投遞的郵件，這在我的測試郵件收件箱。但它從未從Microsoft Outlook發送的原始無法投遞的電子郵件中讀取並將這些電子郵件逐一轉換爲中文字符。

我用google搜索了一下，看起來他們是Outlook中的一些錯誤，因爲發送失敗的郵件。你們有沒有人知道如何解決這個問題？或者有什麼方法可以改進我的代碼？我願意改變任何事情。

來源

2017-04-01 dayaoyao

電子郵件是否來自同一個發件人？哪個辦公室正在使用？ – 0m3r

@ 0m3r其中大部分來自Microsoft Outlook，但其中一些來自[email protected] - 各種服務器，如hotmail或其他公司域名。我正在使用Microsoft Office 365 ProPlus，我認爲它的版本是1609. – dayaoyao

後沮喪了好幾天，我終於想出了一個更簡單的解決方案，這並不需要擔心在Outlook NDR的任何限制，甚至從未使用VBA在所有...

我所做的是：

在Outlook中選擇所有未送達的郵件
另存爲一個名爲「.txt」文件
打開Excel，打開txt文件，並選擇‘分隔符號’，然後選擇‘標籤’作爲分隔符「文本導入嚮導」
篩選出該列的有「爲：」，然後將獲得B列的所有電子郵件地址

不能相信這是比VBA更簡單...

感謝你們你的幫助！只是不能真正處理「Outlook NDR轉向不可讀的字符」錯誤，因爲在工作站上有太多限制，認爲這可能會有所幫助！

來源

2017-04-04 22:04:21 dayaoyao

有與Outlook對象模型（存在於Outlook 2013中ABD 2016）的ReportItem.Body財產的問題 - 你可以看到它在OutlookSpy：選擇一個NDR消息，請單擊項目按鈕，選擇Body屬性 - 這將是亂碼。更糟糕的是，一旦報告項目被OOM觸及，Outlook將在預覽窗格中顯示相同的垃圾。

報告文本存儲在各種MAPI收件人屬性中（單擊OutlookSpy中的IMessage按鈕並轉至GetRecipientTable選項卡）。問題是ReportItem對象不公開收件人集合。該解決方法是使用擴展MAPI（C++或Delphi）或Redemption（任何語言） - 其RDOReportItem .ReportText屬性不會有這樣的問題：

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.Recipients收集來提取各種NDR特性收件人表。

來源

2017-04-01 23:24:39

感謝您的回覆！我研究過你提到的工具，他們似乎很方便。但我工作的公司非常嚴格要在網上下載什麼，因爲我們站的信息是非常保密的。你認爲有沒有其他方法可以解決這個錯誤，而無需下載任何工具？我可以使用類似StrConv（olMail.Body，vbUnicode）的東西嗎？我看到這個在線，但不能讓它工作，雖然 – dayaoyao

我記得在前面看過這個，它似乎是一個8位（ASCII？）字符串作爲UTF-16（IDispatch能COM標準）返回，但即使將它視爲一個8位字符串仍然留下散佈着一些ASCII數據的垃圾。 –

您當然可以切換到擴展MAPI，但需要C++或Delphi。 –

從無法投遞的電子郵件正文中提取文本字符串到excel

回答

相關問題