尝试循环移动电子邮件，但并非所有电子邮件都在第一次运行时被移动 [英] Trying to move emails in a loop, but not all get moved in the first run

问题描述

VBA代码不会将已更新"和项目"中带有特定单词的所有电子邮件从收件箱移动到子文件夹"Neu".电子邮件应该已经阅读.经过5-6次迭代后，所有电子邮件都将被移动.但是，为什么在第一次运行代码后就不能立即使用它呢?也许您遇到过同样的问题?在46封电子邮件中，首先移动了26封，然后是39封，然后是44封，然后是46封.

The VBA code does not move all emails with a certain words in the Subject "has been updated" and "Item" from the inbox to the subfolder "Neu". Emails should be already read. After 5-6 iterations , all emails will be moved. But why doesn't it work immediately after the first time of code running? Maybe you have faced the same problem? Out of 46 emails, 26 of them are moved firstly, then 39, then 44 and then 46.

非常感谢您！

Sub Emails_Outlook_Transport()
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olNS As Outlook.Namespace
    Set olNS = olApp.GetNamespace("MAPI")

    Dim olFldr As Outlook.MAPIFolder
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox)

    Dim Items As Outlook.Items
    Set Items = olFldr.Items

    Dim newFldr As Outlook.MAPIFolder
    Set newFldr = olFldr.Folders("Neu")

    Dim msg As Object
    Dim olMailItem As MailItem
    Dim Found As Boolean

    On Error Resume Next

    For Each msg In Items        
        If TypeOf msg Is MailItem And msg.UnRead = False Then
            Set olMailItem = msg

            If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
                olMailItem.Move newFldr
            End If 
        End If
    Next
End Sub

没有错误消息，只是代码工作不正常

No error messages, just not a proper work of the code

推荐答案

问题:

• 显然，当项目四处移动时，如果发生For Each循环，它会与循环中要引用的项目混淆

• Apparently when the items are moved around, it messes with the item being referred in the loop in case of For Each loop

解决方案:

• 计算完项目数和向后计数后循环工作，以便每个项目都由索引引用.

尝试一下:

Sub Emails_Outlook_Transport()
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olNS As Outlook.NameSpace
    Set olNS = olApp.GetNamespace("MAPI")

    Dim olFldr As Outlook.MAPIFolder
    Set olFldr = olNS.GetDefaultFolder(olFolderInbox)

    Dim Items As Outlook.Items
    Set Items = olFldr.Items

    Dim newFldr As Outlook.MAPIFolder
    Set newFldr = olFldr.Folders("Neu")

    Dim msg As Object
    Dim olMailItem As MailItem
    Dim Found As Boolean

    Dim i As Integer

    For i = Items.Count To 1 Step -1
        If TypeOf Items(i) Is MailItem And Items(i).UnRead = False Then

            Set olMailItem = Items(i)

            If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
                olMailItem.Move newFldr
            End If
        End If
    Next
End Sub

这篇关于尝试循环移动电子邮件，但并非所有电子邮件都在第一次运行时被移动的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！