仅 Outlook VBA 代码一次从文件夹自动转发 2 封电子邮件[重复]答案

【问题标题】：Outlook VBA Code Only Autoforwarding 2 emails at a time from a folder [duplicate]仅 Outlook VBA 代码一次从文件夹自动转发 2 封电子邮件[重复]
【发布时间】：2022-01-27 22:47:50
【问题描述】：

我有一些代码可以检查邮件项何时被放入特定文件夹并循环通过“x”个邮件项并将它们自动转发到另一个电子邮件地址。我遇到的问题是，当我一次丢弃超过 2 封电子邮件时，它只会拾取前两封电子邮件，然后就无法识别任何内容。有谁知道 Outlook 是否对在特定时间范围内发送电子邮件有限制？我正在考虑在每封电子邮件之间添加某种延迟或计时器，看看是否可以解决问题。

如果文件夹中存在现有邮件项，该代码似乎也不起作用，它仅在代码运行时才起作用，然后用户将邮件项放入文件夹中。

任何建议将不胜感激。

Public WithEvents objInbox As Outlook.Folder

Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_StartUp()
Dim olNs As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set objInbox = olNs.Folders("test2@test.com").Folders("test")

Set objInboxItems = objInbox.Items

End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)

Dim objMail As Outlook.MailItem

Dim objForward As Outlook.MailItem

Dim olNs As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Dim olAtt As Attachment
Dim olAtts As Attachments
Dim olSentAtts As Attachments



Set olNs = Application.GetNamespace("MAPI")
'Set shrdRecip = olNs.CreateRecipient("test1@test.com")'
Set objInbox = olNs.Folders("test2@test.com").Folders("test")
Set objForward = Item.Forward
Set destFolder = olNs.Folders("test1@test.com").Folders("arch")
Set srcFolder = olNs.Folders("test2@test.com")


'MsgBox (objMail)'
'objMail.UnRead Or objMail.Sent'
For Each Item In objInbox.Items
 
    If TypeName(Item) = "MailItem" Then
    Set objForward = Item.Forward
    With objForward
    .Subject = Item.Subject
    .HTMLBody = "<HTML><BODY>This message contains an invoice from test1</BODY></HTML>" & objForward.HTMLBody
    .Recipients.Add ("test2@test.com")
    .Recipients.ResolveAll
    'printradu ()'
    .Display
  
   MsgBox (Item.Subject)
   MsgBox (TypeName(Item))
   Dim FilePath As String
   FilePath = "C:\Logs\OutlookLogs.txt"
   TextFile = FreeFile
    'End If'
    End With
    If Err Then
        'MsgBox (Item.Subject + "Failed to send due to: " + Err + "." + "Please try again.")'
        Open FilePath For Append As #1
        Write #1, (CStr(Item.Subject) + " Failed to send due to error code: " + CStr(Err.Description) + "." + "Please try again.")
        'Print #TextFile, (Item.Subject + "Failed to send due to: " + Err + "." + "Please try again.")'
        Close #1
        Item.Move (srcFolder)
    Else
        'MsgBox (Item.Subject + " has been sent successfully.")'
        Open FilePath For Append As #1
        Write #1, ("Subject: " + Item.Subject + " Sent time: " + CStr(Item.SentOn) + " Receieved at: " + CStr(Item.ReceivedTime) + " has been sent successfully.")
        'Print #TextFile, (Item.Subject + " has been sent successfully.")'
        Close #1
        Item.Move (destFolder)
        


    'Item.Move (destFolder)'
    
    End If
    End If
Next Item
'End If'
'Next'
'End Sub'
End Sub

Sub MyTEST()

 

End Sub

【问题讨论】：

标签： vba outlook

【解决方案1】：

您需要使用 for 一个相反的循环，而不是使用 foreach 循环。

当您将项目移动到文件夹时，原始项目将从源文件夹中删除。在这种情况下，Items.Count 属性会减少，因此在这种情况下，您需要以相反的顺序遍历所有项目 - 从 Items.Count 到零。

For myIndex =Items.Count to 1 Step -1 ' Because collections start at 1 not 0

    Items.Item(myIndex).Move(destFolder)

Next

我遇到的问题是，当我一次丢弃超过 2 封电子邮件时，它只会拾取前两封电子邮件，然后就无法识别任何内容。

ItemAdd 事件会针对添加到集合中的每个 Outlook 项目触发。添加的项目作为参数传递。因此，您可以在触发事件时对该项目执行所需的操作，并在循环启动时处理所有其他移交项目。打破现有功能并仅在事件处理程序中处理传递的项目并在启动时为挂在文件夹中的其他项目（剩余）做工作是有意义的。

当大量项目同时添加到文件夹（超过 16 个）时，ItemAdd 事件不会运行。这是处理 OOM 时的一个已知问题。

【讨论】：

谢谢尤金。改用 for 循环解决了我的问题。
如果有帮助，将帖子标记为答案是有意义的。