使用Outlook VBA将特定主题的传入邮件中的数据拉入Excel文件

我编写了VBA代码来提取包含特定主题和标准格式的传入邮件的关键细节，然后将这些数据保存到特定位置的Excel文件中

该代码链接到Outlook规则，该规则将特定主题为“经销商调查问卷的连接性”的电子邮件移动到“经销商调查问卷”文件夹中，然后运行VBA脚本

脚本按预期提取所需数据，并将其保存在占用行下一行

脚本存在以下问题：

它在收到带有特定主题的邮件时运行，但是最新的邮件会丢失，脚本会从文件夹中的第二封邮件开始提取数据。
我认为这与脚本链接到规则有关，该规则同时将邮件移动到特定文件夹，然后运行脚本，因此最初跳过最新邮件

它在文件夹中的所有邮件上运行，这意味着它将覆盖以前保存在Excel文件中的数据。一般来说，只有从文件夹中删除一封或多封邮件后，excel中以前包含的数据才会被覆盖和丢失。此外，随着邮件量的增加，脚本将花费越来越多的时间从所有邮件中提取数据，因此，更好的解决方案是仅从收到的最新电子邮件中提取数据。我试图设置一个脚本，只从“未读邮件”中提取数据，一旦它运行自动读取邮件

如果在邮件到达时，我未处于“收件箱”文件夹中，则会失败。
如果我在任何其他文件夹，它无法提取数据

子MyRule（作为Outlook.MailItem的项目）
出错时继续下一步
设置myOlApp=Outlook.Application
设置myNamespace=myOlApp.GetNamespace（“mapi”）
设置myFolder=myOlApp.ActiveExplorer.CurrentFolder.Folders（“经销商”）
调查问卷“）
作为字符串的Dim strFldr
将邮件变暗为对象
将xlApp作为对象
strFldr=“D:\”
设置xlApp=CreateObject（“Excel.Application”）
xlApp.Application.Visible=True
xlApp.Workbooks.Open strFldr&“\users\xxxxxx\Desktop\destributor
调查问卷\经销商调查问卷.xlsx“
xlApp.Sheets（“Sheet1”）。选择
对于i=1到myFolder.Items.Count
设置myItem=myFolder.Items（i）
msgtext=myItem.Body
xlApp.Range（“a”&i+1）.Value=myItem.ReceivedTime
xlApp.Range（“b”&i+1）.Value=myItem.SenderName
'搜索特定文本
delimtedMessage=替换（msgtext，“经销商名称：”，“####”）
delimtedMessage=替换（delimtedMessage，“经销商实际地址：”，
"###")
delimtedMessage=替换（delimtedMessage，“联系人姓名：”，“####”）
delimtedMessage=替换（delimtedMessage，“联系电子邮件：”，“####”）
delimtedMessage=替换（delimtedMessage，“联系电话：”，“####”）
delimtedMessage=Replace（delimtedMessage），“您有自己的专用邮件吗？”
互联网连接？：“，”###“）
delimtedMessage=Replace（delimtedMessage，“您的连接类型是什么？”，
"###")
delimtedMessage=Replace（delimtedMessage），“您的网络名称是什么
提供者：“，”####“）
delimtedMessage=Replace（delimtedMessage，“官方速度是多少？”：“，
"###")
delimtedMessage=替换（delimtedMessage，“有多少个Wi-Fi接入点
可在建筑物内使用？：“，”####“）
delimtedMessage=Replace（delimtedMessage，“具有带宽和信号
在所有面向客户的区域进行强度测试？：“，”和“###”）
delimtedMessage=Replace（delimtedMessage），“你经历过什么
速度和信号强度的波动？：“，”####“）
delimtedMessage=替换（delimtedMessage），“如果是，最大值是多少
经销商内可达到的最低速度和信号强度？：“，
"###")
delimtedMessage=替换（delimtedMessage，“亲切问候”，“####”）
messageArray=Split（delimtedMessage，“#####”）
“写入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）
下一个
xlApp.Sheets（“Sheet1”）。选择
xlApp.workbook（“经销商调查问卷.xlsx”）。关闭保存更改：=True
xlApp.退出
端接头

这个经常被问到的问题是因为RunAScript格式和独立格式混合在一起

您可以像这样分离代码

子MyRule（incomingItem作为MailItem）
'从一开始就绕过错误。
“这是所有编程中最糟糕的做法。
“移开，不要放回去。
'欢迎错误，以便您可以修复它们。
'出现错误时，请继续下一步
这隐藏了错误。
'通常用于示例代码中，因为正确的错误处理会分散注意力。
'设置myOlApp=Outlook.Application
'Set myNamespace=myOlApp.GetNamespace（“mapi”）
'设置myFolder=myOlApp.ActiveExplorer.CurrentFolder.Folders（“经销商调查问卷”）
msgtext=incomingItem.Body
xlApp.Range（“a”&i+1）.Value=incomingItem.ReceivedTime
xlApp.Range（“b”&i+1）.Value=incomingItem.SenderName
' …    
下一个
' …
端接头
独立子系统
'出现错误时，请继续下一步
'设置myOlApp=Outlook.Application
'Set myNamespace=myOlApp.GetNamespace（“mapi”）
'设置myFolder=myOlApp.ActiveExplorer.CurrentFolder.Folder