Pull data from incoming mails with specific subject into Excel file using Outlook VBA

Question

I have written VBA code to extract key details of incoming mails which contain specific subject and standardised format and then save this data into Excel file within specific location.

The code is linked to an Outlook rule which moves an email with specific subject "Connectivity at the Dealership Questionnaire" into "Dealership Questionnaire" folder and then runs VBA script.

Script extracts required data as expected and saves it one row below the occupied line.

There are issues with the script:

It runs when mail with specific subject is received, however latest email is missed and the script extracts data starting from the second mail in the folder.
I believe this is linked to the fact that script is linked to the rule which at the same time moves the mail into specific folder and then run the script therefore initially latest mail is skipped.
It runs on all mails in the folder meaning that it overwrites the data which was previously saved within the Excel file. Generally speaking it is not an issue until a mail or number of mails is deleted from the folder, then the data previously included in the excel with be overwritten and lost. Additionally with increased volume of mails script will take more and more time to extract the data from all the mails therefore preferable solution would be to extract data only from the latest email received. I tried to set a script which would extract data only from "Unread Mails" and once it runs auto read the mail.
It fails if at the time of mail arrival I'm not actively in the "Inbox" folder.
If I'm at any other folder it fails to extract the data.

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

niton niton · Accepted Answer · 2017-06-12T17:52:04

This often asked question is due to mixing RunAScript format with stand alone format.

You can separate the code like this.

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

Pull data from incoming mails with specific subject into Excel file using Outlook VBA

1 Answers