对于每个循环：通过Outlook邮箱循环删除项目时，某些项目会被跳过 [英] For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

问题描述

$ li <$>

我想开发VBA代码：
$ b

>如果有任何类型的其他项目说日历邀请跳过该项目。找到带有附件的电子邮件

1. 如果附加文件的扩展名为.xml，并且包含特定的标题，则将其保存到目录中，如果没有，继续搜索


2. 在执行步骤4之后，所有电子邮件都会将.xml附件包含到已删除邮件文件夹中，并通过循环删除该文件夹中的所有电子邮件。 b

代码完美无瑕，
例如

1. 有8封电子邮件，每封都附有.xml文件。 / li>
   
2. 运行代码


3. 您将看到8个项目中只有4个成功处理，其他4个项目保留在他们的位置。 $ b
4. 如果您再次运行代码，现在会有2个项目成功处理，另外2个项目仍保留在您的邮箱中。

问题：运行代码后，它应该处理所有文件，并在每次运行中删除它们全部不是它们的一半。我希望它在一次运行中处理所有项目。

顺便说一下，这个代码每次打开Outlook时都会运行。

$ b $私人小程序Application_Startup（）
'初始化Application_Startup强制宏可以从其他办公应用程序访问

'处理XML电子邮件

Dim InboxMsg As Object

Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder

Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
$ b $指定保存附件的文件夹
fPathTemp =某个目录，不要紧
fPathXML_SEM =某个目录，无所谓
fPathEmail_SEM =某个目录，无所谓

'设置Outlook
Set ns = GetNamespace（MAPI）
Set Inbox = ns.Folders.Item（mailbox-name）。Folders（Inbox）
设置DeletedItems = ns.Folders.Item（mailbox-name）。文件夹（删除项目）


'循环所有收件箱中的项目，找到xml附件并处理if他们是匹配的回应
'On Error Resume Next
For Inbox InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then'if it is a mail item

'检查xml附件
对于InboxMsg.Attachments中的每个MsgAttachment

如果Right（MsgAttachment.DisplayName，3）=xmlThen

'加载XML并测试文件的标题
MsgAttachment.SaveAsFile fPathTemp& MsgAttachment.FileName
xmlDoc.Load fPathTemp& MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode（// title）
选择案例xmlTitle.Text
案例特定标题
'获取供应商编号
设置xmlSupNum = xmlDoc.SelectSingleNode（// supplierNum）
'将XML保存到正确的文件夹
MsgAttachment.SaveAsFile fPathXML_SEM& xmlSupNum.Text& _&格式（日期，yyyy-mm-dd）& .xml
将电子邮件保存到正确的文件夹
InboxMsg.SaveAs fPathEmail_SEM& xmlSupNum.Text& _&格式（日期，yyyy-mm-dd）& .msg
删除消息
InboxMsg.Move DeletedItems
Case Else

End Select
'删除临时文件
On错误恢复下一步
杀死fPathTemp& MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
下一个
结束如果
下一个

'循环删除的项目并删除
对于每个InboxMsg在DeletedItems.Items
InboxMsg.Delete
下一个

'清理
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0

End Sub

解决方案

可能的原因：当您执行此操作 InboxMsg.Move 时，收件箱中的所有邮件被移动列表中的一个位置。所以你最终会跳过其中的一些。这是VBA的 For Each 结构中的一个主要烦恼（而且它也不是一致的）。

可能的解决方案：替换

  For Inbox InboxMsg in Inbox.Items 
  

与

  For i = Inbox.Items.Count To 1 Step -1'从结尾向后迭代
 Set InboxMsg = Inbox.Items（i）
  

这样你从列表的末尾迭代。将邮件移动到已删除的项目时，列表中的以下项目因为已经处理完毕而无法处理。

I wanted to develop VBA code that:

1. Loops through all email items in mailbox
2. If there are any type of other items say "Calendar Invitation" skips that item.
3. Finds out the emails with attachments
4. If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
5. Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.

Code works perfect EXCEPT; For example

1. There are 8 email received with ".xml" file attached to each one of them in your mailbox.
2. run the code
3. you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
4. If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.

Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.

BTW, this code runs every time I open the Outlook.

Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps

'Process XML emails

Dim InboxMsg As Object

Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder

Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode

    'Specify the folder where the attachments will be saved
    fPathTemp = "some directory, doesn't matter"
    fPathXML_SEM = "some directory, doesn't matter"
    fPathEmail_SEM = "some directory, doesn't matter"

    'Setup Outlook
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
    Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")


    'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
    'On Error Resume Next
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then 'if it is a mail item

            'Check for xml attachement
            For Each MsgAttachment In InboxMsg.Attachments

                If Right(MsgAttachment.DisplayName, 3) = "xml" Then

                    'Load XML and test for the title of the file
                    MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
                    xmlDoc.Load fPathTemp & MsgAttachment.FileName
                    Set xmlTitle = xmlDoc.SelectSingleNode("//title")
                    Select Case xmlTitle.Text
                        Case "specific title"
                            'Get supplier number
                            Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
                            'Save the XML to the correct folder
                            MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
                            'Save the email to the correct folder
                            InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
                            'Delete the message
                            InboxMsg.Move DeletedItems
                        Case Else

                    End Select
                    'Delete the temp file
                    On Error Resume Next
                    Kill fPathTemp & MsgAttachment.FileName
                    On Error GoTo 0
                    'Unload xmldoc
                    Set xmlDoc = Nothing
                    Set xmlTitle = Nothing
                    Set xmlSupNum = Nothing
                End If
            Next
        End If
    Next

    'Loop through deleted items and delete
    For Each InboxMsg In DeletedItems.Items
        InboxMsg.Delete
    Next

    'Clean-up
    Set InboxMsg = Nothing
    Set DeletedItems = Nothing
    Set MsgAttachment = Nothing
    Set ns = Nothing
    Set Inbox = Nothing
    i = 0

End Sub

解决方案

Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).

Likely solution: Replace

For Each InboxMsg In Inbox.Items

with

For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
    Set InboxMsg = Inbox.Items(i)

This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.

这篇关于对于每个循环：通过Outlook邮箱循环删除项目时，某些项目会被跳过的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！