English 中文(简体)
对于每个循环 : 当通过 Outlook 邮箱循环删除项目时, 某些项目会被跳过 。
原标题:For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

我想制定VBA守则:

  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.

问题 : 运行代码后, 它应该处理所有文件, 并删除所有文件, 而不是每个运行中一半的文件 。 我希望它能在一个运行中处理所有项目 。

BTW 每次我打开《展望》 都用这个代码

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
最佳回答

可能的原因 : 当您做此 < code> InboxMsg. Move 时, 您的收件箱中在移动信件后的所有信件都会在列表中被一个位置叠叠起来。 所以最后您跳过其中某些位置。 这是对每个 < /code > 构建的 VBA s < code> 进行的重大烦恼( 而且它似乎也不一致 ) 。

可能的解决办法:替换

For Each InboxMsg In Inbox.Items

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

这样您就会从列表的末尾向后偏移。 当您将信件移到删除的项目时, 当列表中的以下项目被一个叠叠起来时, 并不重要, 因为您已经处理过它们 。

问题回答

绕过一个( 子) 集的项目时修改其内容通常不是一个好主意。 您可以修改您的代码, 以便它首先识别所有需要处理的项目, 并将其添加到 < code> Collection 中。 然后处理该收藏中的所有项目 。

基本上,您不应该在重新循环内容时从收件箱中删除项目。首先收集您想要处理的所有项目(在收件箱循环中),然后当您重新循环时,处理收集的项目。

这里有些假代码可以证明这一点:

Private Sub Application_Startup()

    Dim collItems As New Collection

     Start by identifying messages of interest and add them to a collection
    For Each InboxMsg In Inbox.Items
        If InboxMsg.Class = olMail Then  if it is a mail item
            For Each MsgAttachment In InboxMsg.Attachments
                If Right(MsgAttachment.DisplayName, 3) = "xml" Then
                    collItems.Add InboxMsg
                    Exit For
                End If
            Next
        End If
    Next

     now deal with the identified messages
    For Each InboxMsg In collItems
        ProcessMessage InboxMsg
    Next InboxMsg

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

End Sub

Sub ProcessMessage(InboxMsg As Object)
     deal with attachment(s) and delete message
End Sub




相关问题
Handling no results for docmd.applyfilter

I have an Access app where I use search functionality. I have a TextBox and a Search Button on the form, and it does a wildcard search of whatever the user enters in the TextBox, and displays the ...

Outlook 2007 CommandBarControl.Execute won t work

I recently switched to Outlook 2007 and noticed that my VBA-macros won t work. I use the following code to open a new appointment-item (and fill it automatically). It worked perfect in Outlook 2003, ...

Connecting to Oracle 10g with ODBC from Excel VBA

The following code works. the connection opens fine but recordset.recordCount always returns -1 when there is data in the table. ANd If I try to call any methods/properties on recordset it crashes ...

MS Access: list macro from VBA

I have to deal with a few macros (not VBA) in an inherited Access application. In order to document them, I would like to print or list the actions in those macros, but I am very dissatisfied by ...

热门标签