Outlook VBA pour extraire les données des courriers entrants avec un sujet spécifique dans le fichier Excel

Question

J'ai écrit un simple code VBA pour extraire les détails clés des mails entrants qui contiennent un sujet spécifique et un format standardisé, puis enregistrer ces données dans un fichier Excel à un endroit spécifique .

Le code vba est lié à une règle de perspective qui déplace un e-mail avec un sujet spécifique "Connectivity at the Dealership Questionnaire" dans le dossier "Dealership Questionnaire", puis exécute le script VBA.

Le script fonctionne bien car il extrait les données requises comme prévu et les enregistre toujours une ligne en dessous de la ligne occupée.

Maintenant, il y a deux questions clés avec le script que je me bats pour surmonter:

1. Script, ne prend le dernier e-mail qui vient de recevoir - il fonctionne correctement lorsque le courrier avec le sujet spécifique est reçu, cependant le dernier email est manqué et le script extrait des données seulement à partir du deuxième courrier dans le dossier. - Je crois que ceci est lié au fait que le script est lié à la règle qui déplace en même temps le mail dans un dossier spécifique et exécute ensuite le script donc au départ le dernier courrier est ignoré.

2. Le script s'exécute sur tous les courriers du dossier, ce qui signifie qu'il écrase les données précédemment enregistrées dans le fichier Excel. D'une manière générale ce n'est pas un problème jusqu'à ce qu'un courrier ou un nombre de mails est supprimé du dossier, alors les données précédemment incluses dans l'excel avec être écrasées sont perdues. De plus, avec l'augmentation du volume de mails, le script prendra de plus en plus de temps pour extraire les données de tous les mails, donc une solution préférable serait d'extraire des données uniquement à partir du dernier email reçu. J'essayais de définir un script qui extrairait des données uniquement à partir de "Unread Mails" et une fois qu'il s'exécute, il lit automatiquement le mail, mais j'ai échoué. Script a un peu de défaut, que même s'il pointe vers un dossier spécifique pour extraire les données, il ne parvient pas à le faire, si au moment de l'arrivée du courrier, je ne suis pas activement dans le dossier "Inbox", ce qui signifie que si je suis dans un autre sous-dossier dans Outlook et que le script est déclenché à ce point, que si je n'arrive pas à extraire les données.

J'apprécierait votre conseiller pour faire face au moins une des questions ci-dessus, je suis un novice en VBA et la plupart des scripts que je produis sont fondés sur la pratique « d'essais et d'erreurs ». La version actuelle du script peut être trouvée ci-dessous:

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

Cette question souvent posée est due au mélange du format RunAScript avec le format autonome.

Vous pouvez séparer le code comme ceci.

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