Question

我编写了一个简单的VBA代码，用于从包含特定主题和标准格式的传入邮件中提取关键详细信息，然后将这些数据保存到特定位置的excel文件中。

vba代码链接到Outlook规则，该规则会移动具有特定主题的电子邮件＆＃34;经销商调查问卷中的连接性＆＃34;进入＆＃34;经销商调查问卷＆＃34;文件夹，然后运行VBA脚本。

脚本运行良好，因为它按预期提取所需数据并将其保存在占用行下方一行。

现在，我努力克服的脚本存在几个关键问题：

脚本，永远不会选择刚收到的最新电子邮件 - 当收到带有特定主题的邮件时，它会正确运行，但会丢失最新的电子邮件，并且脚本仅从文件夹中的第二封邮件中提取数据。 - 我认为这与脚本链接到规则的事实有关，该规则同时将邮件移动到特定文件夹然后运行脚本，因此最初会跳过最新邮件。
脚本在文件夹中的所有邮件上运行，这意味着它会覆盖以前保存在Excel文件中的数据。一般来说，在从文件夹中删除邮件或邮件数量之前，这不是问题，然后先前包含在excel中的数据将被覆盖丢失。此外，随着邮件量的增加，脚本将花费越来越多的时间从所有邮件中提取数据，因此优选的解决方案是仅从收到的最新电子邮件中提取数据。我试图设置一个脚本，它只能从＆＃34; Unread Mails＆＃34;中提取数据。一旦它运行自动读取邮件，但我在这方面失败了。
脚本有一些缺陷，即使它指向特定的文件夹来提取数据也无法做到，如果在邮件到达时我没有积极参与＆＃34 ;收件箱＆＃34;文件夹，意味着如果我在Outlook和脚本中的任何其他子文件夹中被触发，那么就比无法提取数据。

我非常感谢您的建议，至少解决上述问题之一，我只是VBA的新手，我制作的大部分脚本都基于＆＃34;试错＆＃34;实践。当前版本的脚本可以在下面找到：

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

Outlook VBA将具有特定主题的传入邮件中的数据提取到Excel文件中

1 个答案: