Outlook無法投遞的退回報表項搜索問題，VBA

我在文件夾中有一些無法投遞的電子郵件。我正在嘗試瀏覽該文件夾中的每封電子郵件，並通過搜索該郵件來提取目標收件人的電子郵件地址。Outlook無法投遞的退回報表項搜索問題，VBA

我有一些VBA代碼在普通電子郵件上工作，但由於無法投遞的不是Outlook「郵件項目」，它們是Outlook「報告項目」，我在搜索郵件時遇到問題。搜索功能迴歸空白，經過大量研究，似乎「報告項目」實際上並沒有可以搜索的「身體」。

報告中的所有錯誤報告中的電子郵件格式如下。

([email protected])

這是我使用的代碼，它對普通郵件項目起作用。

Sub Undeliver() 

On Error Resume Next 
Set myOlApp = Outlook.Application 
Set mynamespace = myOlApp.GetNamespace("MAPI") 

'Selects the current active folder to use 
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder 

'creates excel spreadsheet where data will go 
Set xlobj = CreateObject("excel.application") 
xlobj.Visible = True 
xlobj.Workbooks.Add 

'names column a row 1 "email" and column b row 1 "else" 
xlobj.Range("a" & 1).Value = "Email" 
xlobj.Range("b" & 1).Value = "Else" 

'loops through all the items in the current folder selected 
For I = 1 To myfolder.Items.Count 
    Set myitem = myfolder.Items(I) 

    'selects the body of the current email being searched 
    msgtext = myitem.Body 

    'searches the body for the first open parentheses and first close 
    'parentheses and copies the value in between into an array 
    delimtedMessage = Replace(msgtext, "(", "###") 
    delimtedMessage = Replace(delimtedMessage, ")", "###") 

    'splits the array up into two pieces 
    messageArray = Split(delimitedMessage, "###") 

    'this inputs the values of the array into my excel spreadsheet 
    xlobj.Range("a" & I + 1).Value = messageArray(1) 
    xlobj.Range("b" & I + 1).Value = messageArray(2) 
Next I 

End Sub

有沒有人知道我可以如何訪問報告的消息部分用於搜索目的？

來源

2015-11-04 jerome Williams

（我刪除了您標題爲「解決」。既然你接受了答案，那就是對他人有類似的問題的正確指示。） – usr2564301

我最終解決的解決方案涉及將消息正文轉換回Unicode，然後搜索我需要的內容。這最終實現起來非常簡單。

這是我完成的工作代碼，供將來參考。我最終添加了一個進度條來監視它在代碼中的位置。它不幸運行速度相當慢，但它完成了工作。

希望這可以幫助未來的人！

On Error Resume Next 
Set myOlApp = Outlook.Application 
Set mynamespace = myOlApp.GetNamespace("MAPI") 

Set xlobj = CreateObject("excel.application") 
xlobj.Visible = True 
xlobj.Workbooks.Add 

xlobj.Range("a" & 1).Value = "Email" 
xlobj.Application.displayStatusBar = True 

For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count 
    Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I) 
    msgtext = StrConv(myitem.Body, vbUnicode) 

    delimtedMessage = Replace(msgtext, "mailto:", "###") 
    delimtedMessage = Replace(delimtedMessage, "</a><br>", "###") 
    messageArray = Split(delimtedMessage, "###") 

    xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0) 
    xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I/myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%") 
Next I 

xlobj.Application.displayStatusBar = False

來源

2015-11-09 22:20:24

那麼，總有this解決方案。

要點是ReportItem.Body返回一個不可讀的字符串，所以此解決方案將ReportItem保存爲文本文件，然後解析文本文件。它不完全優雅，但它應該工作。

希望這會有所幫助！

來源

2015-11-04 23:59:03

這個解決方案很有趣，但在論壇的底部，有另一個想法，我曾用它來解決這個問題。謝謝！ –

Outlook無法投遞的退回報表項搜索問題，VBA

回答

相關問題