Search code examples
excelvbaoutlookmailitem

Error while sending multiple items from the drafts using Excel VBA


I have a list of email ids in Excel and I have a number of drafts stored.

I am trying to send particular drafts to the list of email ids based on the subject line of the drafts.

There is an error on the line .copy and .send when I have multiple drafts present but not when only one draft is present.

Sub eng()

    Dim lDraftItem, myOutlook, myNameSpace, myFolders, myDraftsFolder

    Set myOutlook = CreateObject("Outlook.Application")
    Set myNameSpace = myOutlook.GetNamespace("MAPI")

    myNameSpace.Logon "Outlook"

    Set myFolders = myNameSpace.Folders
    Set myDraftsFolder = myFolders("[email protected]").Folders("Drafts")

    For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
        If InStr(myDraftsFolder.Items.item(lDraftItem).subject, "Subjectline") <> 0 Then

            For i = 2 To iTotalRows
                myDraftsFolder.Items.item(lDraftItem).Copy
                myDraftsFolder.Items.item(lDraftItem).SentOnBehalfOfName = "email"
                myDraftsFolder.Items.item(lDraftItem).To = "email"
                myDraftsFolder.Items.item(lDraftItem).Send
            Next

        End If
    Next lDraftItem

    Set myDraftsFolder = Nothing
    Set myNameSpace = Nothing
    Set myOutlook = Nothing

End Sub

Solution

  • This is multiple dot notation taken to an extreme. Secondly, MailItem.Copy returns the newly created (copied) item. You are ignoring the returned value. Did you mean the following?

    set items = myDraftsFolder.Items
    For lDraftItem = items.Count To 1 Step -1
        set item = items.Item(lDraftItem)
        If InStr(item.subject, "Subjectline") <> 0 Then
    
            For i = 2 To iTotalRows
                set newItem = item.Copy
                newItem.SentOnBehalfOfName = "email"
                newItem.To = "email"
                newItem.Send
            Next
    
        End If
    Next lDraftItem