特定の件名の着信メールからExcelファイルにデータをプルするためのOutlook VBA

Question

特定の件名と標準化された形式を含む受信メールの重要な詳細を抽出し、特定の場所内のExcelファイルに保存する単純なVBAコードを作成しました。

vbaコードは、特定の件名「接続性アンケート」の電子メールを「販売店アンケート」フォルダに移動してからVBAスクリプトを実行するOutlookルールにリンクされています。

スクリプトは、必要なデータを期待通りに抽出し、常に占有されている行の1行下に保存するので、うまく機能します。

今は、私が克服するために苦労してるスクリプトで重要な問題がいくつかあります：

1. スクリプトは、ちょうど受信された最新のメール選ぶことはありません - それは、特定の対象とする場合、メールが正しく動作しますが最新の電子メールが失われ、スクリプトはフォルダ内の2番目のメールからのみデータを抽出します。 - これは、スクリプトが同時に特定のフォルダにメールを移動してスクリプトを実行するルールにリンクされているため、最初に最新のメールをスキップするという事実に関連していると思います。

2. スクリプトは、フォルダ内のすべてのメールで実行され、以前にExcelファイル内に保存されたデータを上書きすることを意味します。一般的に言えば、メールやメールの数がフォルダから削除されるまで問題はありません。以前にExcelに含まれていたデータは上書きされて失われます。さらに、メールの量を増やすと、スクリプトはすべてのメールからデータを抽出するためにますます多くの時間を要します。したがって、受信した最新の電子メールからのみデータを抽出することをお勧めします。私は「Unread Mails」からのみデータを抽出するスクリプトを設定しようとしていましたが、一度自動読み込みを実行すると、これで失敗しました。

3. スクリプトには、メールの到着時に「受信トレイ」フォルダに積極的に存在しない場合、データを抽出する特定のフォルダを指しているにもかかわらず、私がoutlook内の他のサブフォルダにいて、その時点でスクリプトがトリガされている場合、データを抽出できない場合よりも。私は非常に上記の問題の少なくとも1つに対処するあなたのアドバイスをいただければ幸いです

、私は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