Outlook VBA將來自具有特定主題的傳入郵件的數據導入Excel文件

Question

我已經編寫了一個簡單的VBA代碼，用於從包含特定主題和標準格式的傳入郵件中提取關鍵詳細信息，然後將此數據保存到特定位置的excel文件中。

vba代碼鏈接到outlook規則，該規則將具有特定主題「經銷商問卷連接」的電子郵件移動到「經銷商問卷」文件夾中，然後運行VBA腳本。

腳本運行良好，因爲它按預期提取所需數據並將其始終保存在佔用線以下一行。

現在，有幾個與腳本，我努力克服的關鍵問題：

1. 腳本，從來沒有拿起這是剛剛收到的最新電子郵件 - 它正常運行時具有特定主題的郵件被接收，但是最新的電子郵件被遺漏，並且腳本僅從文件夾中的第二郵件開始提取數據。 - 我相信這是與該腳本鏈接到其在同一時間將郵件移動到特定的文件夾，然後運行該腳本，因此最初的最新郵件被跳過規則的事實。

2. 腳本在文件夾中的所有郵件上運行，這意味着它將覆蓋以前保存在Excel文件中的數據。通常來說，直到郵件的郵件或號碼從文件夾中刪除的問題，那麼以前包含在Excel中的數據與被覆蓋的丟失。另外與郵件腳本量增長將越來越多的時間，從所有的郵件因此，最好的解決辦法是隻提取從收到的最新電子郵件數據提取數據。我試圖設置一個腳本，它只能從「未讀郵件」中提取數據，一旦它運行自動閱讀郵件，但是我失敗了。

3. 腳本有一點缺陷，即使它指向特定的文件夾來提取數據，但它無法做到這一點，如果在郵件到達時我不主動地位於「收件箱」文件夾中，意思是如果我在Outlook中的任何其他子文件夾中並且此時觸發了腳本，則比如果無法提取數據。

我將非常感謝您的提醒，解決的上述問題中的至少一個，我只是在VBA新手最我產生的腳本是基於「試錯」的做法。當前版本的腳本可以在下面找到：

Sub MyRule(Item As Outlook.MailItem) 
On Error Resume Next 
Set myOlApp = Outlook.Application 
Set myNamespace = myOlApp.GetNamespace("mapi") 
Set myFolder = myOlApp.ActiveExplorer.CurrentFolder.Folders("Dealership 
Questionnaire") 

Dim strFldr As String 
Dim OutMail As Object 
Dim xlApp As Object 
strFldr = "D:\" 
Set xlApp = CreateObject("Excel.Application") 
xlApp.Application.Visible = True 
xlApp.Workbooks.Open strFldr & "\users\xxxxxx\Desktop\Dealership 
Questionnaire\Dealership Questionnaire.xlsx" 
xlApp.Sheets("Sheet1").Select 

For i = 1 To myFolder.Items.Count 
Set myItem = myFolder.Items(i) 
msgtext = myItem.Body 

xlApp.Range("a" & i + 1).Value = myItem.ReceivedTime 
xlApp.Range("b" & i + 1).Value = myItem.SenderName 
'search for specific text 
delimtedMessage = Replace(msgtext, "Dealer Name:", "###") 
delimtedMessage = Replace(delimtedMessage, "Dealer Physical Address:", 
"###") 
delimtedMessage = Replace(delimtedMessage, "Contact Name:", "###") 
delimtedMessage = Replace(delimtedMessage, "Contact Email:", "###") 
delimtedMessage = Replace(delimtedMessage, "Contact Phone:", "###") 
delimtedMessage = Replace(delimtedMessage, "Do you have your own dedicated 
internet connection?:", "###") 
delimtedMessage = Replace(delimtedMessage, "What is your connection type:", 
"###") 
delimtedMessage = Replace(delimtedMessage, "What is the name of your network 
provider:", "###") 
delimtedMessage = Replace(delimtedMessage, "What is the official speed?: ", 
"###") 
delimtedMessage = Replace(delimtedMessage, "How many Wi-Fi access points are 
avaliable within the building?:", "###") 
delimtedMessage = Replace(delimtedMessage, "Have the bandwidth and signal 
strength been tested across all of the customer facing areas?:", "###") 
delimtedMessage = Replace(delimtedMessage, "Have you experienced any 
fluctuations in the speed and signal strength? : ", "###") 
delimtedMessage = Replace(delimtedMessage, "If so what is the maximum and 
minimum achivable speed and signal strength within the dealership? : ", 
"###") 
delimtedMessage = Replace(delimtedMessage, "Kind Regards ", "###") 

messageArray = Split(delimtedMessage, "###") 
'write to excel 
xlApp.Range("c" & i + 1).Value = messageArray(1) 
xlApp.Range("d" & i + 1).Value = messageArray(2) 
xlApp.Range("e" & i + 1).Value = messageArray(3) 
xlApp.Range("f" & i + 1).Value = messageArray(4) 
xlApp.Range("g" & i + 1).Value = messageArray(5) 
xlApp.Range("h" & i + 1).Value = messageArray(6) 
xlApp.Range("i" & i + 1).Value = messageArray(7) 
xlApp.Range("j" & i + 1).Value = messageArray(8) 
xlApp.Range("k" & i + 1).Value = messageArray(9) 
xlApp.Range("l" & i + 1).Value = messageArray(10) 
xlApp.Range("m" & i + 1).Value = messageArray(11) 
xlApp.Range("n" & i + 1).Value = messageArray(12) 
xlApp.Range("o" & i + 1).Value = messageArray(13) 
xlApp.Range("p" & i + 1).Value = messageArray(14) 

Next 

xlApp.Sheets("Sheet1").Select 
xlApp.Workbooks("Dealership Questionnaire.xlsx").Close savechanges:=True 
xlApp.Quit 

End Sub 

Answer 1

這個經常被問到的問題是由於混合RunAScript格式與獨立格式。

您可以將代碼分開這樣。

Sub MyRule(incomingItem As MailItem) 

' Bypassing errors from the start. 
' The worst practice in ALL programming. 
' Remove and do not put it back. 
' Welcome the errors so you can fix them. 

' On Error Resume Next 

' This hides errors. 
' Often used in sample code as proper error handling is distracting. 


' Set myOlApp = Outlook.Application 
' Set myNamespace = myOlApp.GetNamespace("mapi") 
' Set myFolder = myOlApp.ActiveExplorer.CurrentFolder.Folders("Dealership Questionnaire") 

msgtext = incomingItem.Body 

xlApp.Range("a" & i + 1).Value = incomingItem.ReceivedTime 
xlApp.Range("b" & i + 1).Value = incomingItem.SenderName 

' …  

Next 

' … 
End Sub 


Sub MyStandAlone 

' On Error Resume Next 
' Set myOlApp = Outlook.Application 
' Set myNamespace = myOlApp.GetNamespace("mapi") 
' Set myFolder = myOlApp.ActiveExplorer.CurrentFolder.Folders("Dealership Questionnaire") 

' While VBA is in Outlook, Outlook = Application 
' Note: This is not correct but the error would have been 
' hidden by On Error Resume next 
'Set myFolder = Application.ActiveExplorer.CurrentFolder.Folders("Dealership Questionnaire") 
' Or simply 
' Set myFolder = ActiveExplorer.CurrentFolder.Folders("Dealership Questionnaire") 

' Something like this references a folder under the inbox 
Set myFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Dealership Questionnaire") 

' …. 

For i = 1 To myFolder.Items.Count 

    Set myItem = myFolder.Items(i) 
    msgtext = myItem.Body 

    xlApp.Range("a" & i + 1).Value = myItem.ReceivedTime 
    xlApp.Range("b" & i + 1).Value = myItem.SenderName 

    ' ...  
Next 

' …. 
End Sub