Save composed emails to Outlook drafts

Question

This answer posted by ibo on 07/02/18 works for a limited number of emails.

I will have at least 500 emails to send and my concern is running into a resource issue with that many open windows. I can run the routine in batches, with unsent emails saved to drafts after 1 min (based on a setting in Outlook), then can close all at once from the view tab without having to save each one.

I have a macro that can send all drafts at once. Can this code be modified or code added so that I don't end up with an open window for each email composed? i.e. each email would be saved to the drafts folder automatically.

Option Explicit

Public app As String
Public version As String

Option Explicit

Sub Consolidate()

#If Early Then
    Dim emailInformation As New Scripting.Dictionary
#Else
    Dim emailInformation As Object
    Set emailInformation = CreateObject("Scripting.Dictionary")
#End If

    GetEmailInformation emailInformation
    SendInfoEmail emailInformation
End Sub


Sub GetEmailInformation(emailInformation As Object)

Dim rg As Range
Dim sngRow As Range

Dim emailAddress As String
Dim myAppInfo As AppInfo
Dim AppInfos As Collection

Set rg = Range("A1").CurrentRegion    ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)    ' Cut the headings

    For Each sngRow In rg.Rows

        emailAddress = sngRow.Cells(1, 1)

        Set myAppInfo = New AppInfo
        With myAppInfo
            .app = sngRow.Cells(1, 2)
            .version = sngRow.Cells(1, 3)
        End With

        If emailInformation.Exists(emailAddress) Then
            emailInformation.item(emailAddress).Add myAppInfo
        Else
            Set AppInfos = New Collection
            AppInfos.Add myAppInfo
            emailInformation.Add emailAddress, AppInfos
        End If

    Next

End Sub


Sub SendInfoEmail(emailInformation As Object)

Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant

    sBodyStart = "Hi, please find your account permissions below:" & vbCrLf

    For Each emailAdress In emailInformation
        Set colLines = emailInformation(emailAdress)
        sBodyInfo = ""
        For Each line In colLines
            sBodyInfo = sBodyInfo & _
                        "Application: " & line.app & vbTab & "Version:" & line.version & vbCrLf
        Next
        sBodyEnd = "Best Regards" & vbCrLf & _
                   "Team"

        sBody = sBodyStart & sBodyInfo & sBodyEnd
        SendEmail emailAdress, "Permissions", sBody
    Next

End Sub


Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
              , ByVal sBody As String _
              , Optional ByRef coll As Collection)

    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.Add item
            Next
        End If

        .Display
        '.Send
    End With

    Set outMail = Nothing

End Sub

user_1603351 · Answer

First of all, it is not a good idea to create a new Outlook application instance each time you need to send an email. Instead, you may create a new Outlook instance in the SendInfoEmail method once and then re-use in the SendEmail method. But now a new Outlook Application is created along with an item.

If you don't want to display each item in a separate Outlook window you need to replace the following line of code:

.Display

with the following one:

.Save

So, your code may look like that:

Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
                , ByVal sBody As String _
                  , Optional ByRef coll As Collection)


    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.Add item
            Next
        End If

        .Save
        '.Send
    End With

    Set outMail = Nothing

End Sub

Save composed emails to Outlook drafts

1 Answers