Question

我试图遍历Outlook电子邮件的选定内容或文件夹，将相同的文件附加到每个电子邮件并将其转发到相同的电子邮件地址。

我以前尝试过使用for循环，但是当有很多电子邮件（超过100封）时，Outlook告诉我它内存不足，无法转发电子邮件。

我现在尝试使用while循环来执行此操作。下面是我的代码。它不起作用。我应该改变什么？

Sub ForwardSelectedItems()

Dim forwardmail As Outlook.mailItem
Dim Selection As Selection
Dim n As Integer
Set Selection = Application.ActiveExplorer.Selection

Set n = Selection.Count

Do While n > 0

    Set forwardmail = Selection.Item(1).forward

    'Email recipient address
    forwardmail.Recipients.Add "test@test.com"

    'File Path 
    forwardmail.Attachments.Add ("C:\temp\test.xlsx")

    forwardmail.Send
Next
End Sub

Answer 1

下面的代码正在运行。当子文件夹中有80封电子邮件时，我已经尝试过了。我让它循环通过文件夹而不是选择。

Sub SendFolderItemsWithAttachments()

    Dim MyFolder As MAPIFolder
    Set MyFolder = Application.Session.Folders("Name").Folders("Inbox").Folders("Subfolder")

    Dim forwarditems As Items
    Set forwarditems = MyFolder.Items

    Dim i As Long
    For i = forwarditems.Count To 1 Step -1

        Set forwardmail = forwarditems.Item(i).forward

        'Email recipient address
        forwardmail.Recipients.Add "test@test.com"

        'File Path
        forwardmail.Attachments.Add ("C:\Temp\filename.xlsx")

        forwardmail.Send

    Next

End Sub

Answer 2

设置用于对象。

Sub ForwardSelectedItems_V2()

'Dim forwardmail As outlook.mailItem
Dim forwardmail As mailItem
Dim itm As Object

'Dim Selection As Selection
Dim itmSel As Selection

'Dim n As Integer
Dim n As Long

'Set Selection = Application.ActiveExplorer.Selection
Set itmSel = ActiveExplorer.Selection

' Set is for objects
'Set n = Selection.count
n = itmSel.count

Do While n > 0

    ' The first item in the collection "Item(1)" never changes.
    ' This can be used if the first item
    '  is removed from the collection in each iteration.
    ' Not the case here.
    ' Set forwardmail = Selection.Item(1).forward

    Set itm = itmSel.Item(n)

    'If itm is not a mailitem, the object may not have a method you expect.
    If itm.Class = olMail Then

        Set forwardmail = itm.Forward

        'Email recipient address
        forwardmail.Recipients.Add "test@test.com"

        'File Path
        forwardmail.Attachments.Add ("C:\temp\test.xlsx")

        forwardmail.Display
        'forwardmail.Send

    End If

    ' not a For Next loop so n has to be manipulated "manually"
    n = n - 1

'Next
Loop

End Sub

使用VBA在Outlook中一对一转发大量电子邮件

2 个答案: