Производительность электронной почты Outlook снижается при использовании Excel VBA

Question

Outlook отправляет электронные письма очень медленно.

Более того, мой ЦП работает на 15-20%, а мой 16-ГБ ОЗУ загружен на 50% ... так что это может быть проблемой производительности кода или распределения ресурсов.

У меня естьвключил мой код ниже:

 'my code
    Sub SendMail(what_address As String, subject_line As String, mail_body As String)

    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

        Dim olMail As Outlook.MailItem
        Set olMail = olApp.CreateItem(olMailItem)

        With olMail
            .To = what_address
            .Subject = subject_line
            .BodyFormat = olFormatHTML
            .Attachments.Add "C:\Users\User\Documents\Association\Event Brochure\BROCHURE.pdf"
            .HTMLBody = mail_body
            .Send
        End With

    End Sub 'Tells outlook to send an input, with an attachment I selected


    Sub SendMassMail()

    row_number = 1

    Do
    DoEvents
        row_number = row_number + 1
        Dim mail_body_message As String
        Dim name As String
        Dim mrmrs As String
        Dim company_name As String

        mail_body_message = Sheet1.Range("I2")
        name = Sheet1.Range("B" & row_number)
        mrmrs = Sheet1.Range("C" & row_number)
        company_name = Sheet1.Range("D" & row_number)

        mail_body_message = Replace(mail_body_message, "replace_mrmrs_here", mrmrs)
        mail_body_message = Replace(mail_body_message, "replace_name_here", name)
        mail_body_message = Replace(mail_body_message, "replace_company_here", company_name)


        Call SendMail(Sheet1.Range("A" & row_number), "Event Sponsorship", mail_body_message)

    Loop Until row_number = 500

    End Sub

Этот код представляет собой два макроса, которые я создал в листе Excel, который содержит адреса электронной почты в столбце A, имена в столбце B, Mr / Mrs в столбце C, компания в столбце Dи, наконец, тело сообщения в ячейке I2, в котором есть ключевые слова, подлежащие замене для каждого получателя.

Теперь о распределении ресурсов.В диспетчере задач я дал приоритет как Excel.exe, так и Outlook.exe.

Мой код работает плохо, потому что я вызываю другую функцию, когда использую Call SendMail?

Мой код работает плохо, потому что я использую DoEvent?Это единственный метод, который я знаю ... поэтому, если вы предлагаете другой метод, отличный от DoEvent, пожалуйста, объясните, что он делает.

Answer 1

Вот быстрое переписывание, где я:

1. Поместите весь код в одну процедуру.Мы создаем приложение outlook один раз и много раз отправляем из одного экземпляра
2. Переключенный на цикл For Each, который немного чище
3. Удален DoEvents в комментарии. IF вам абсолютно необходимо иметь возможность прервать выполнение кода во время его выполнения, тогда вы захотите сохранить DoEvents в своем цикле.Если вам все равно, и вы хотите, чтобы вещь работала как можно быстрее, оставьте это.Я бы предположил (как заметил @JoshEller), что сохранение этих электронных писем как черновиков в первую очередь может быть лучшей альтернативой.Затем вы можете отправить вручную из своего мировоззрения, ловя любые ошибки, которые могли быть допущены, пока не стало слишком поздно (и неловко).

Sub SendMassMail()  
    'Create your outlook object once:
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    'Declare your mail object
    Dim olMail As Outlook.MailItem

    'Some variables used in the loop. Declare outside:
    Dim mail_body_message As String
    Dim name As String
    Dim mrmrs As String
    Dim company_name As String

    'Do your loop. Using a for loop here so we don't need a counter
    Dim rngRow as Range
    For each rngRow in Sheet1.Range("B2:B500").Rows
        'No reason to do this here
        'DoEvents

        mail_body_message = Sheet1.Range("I2")
        name = rngRow.Cells(1, 2).value 'Column B
        mrmrs = rngRow.Cells(1, 3).Value 'Column C
        company_name = rngRow.Cells(1, 4).value 'Column D

        mail_body_message = Replace(mail_body_message, "replace_mrmrs_here", mrmrs)
        mail_body_message = Replace(mail_body_message, "replace_name_here", name)
        mail_body_message = Replace(mail_body_message, "replace_company_here", company_name)

        'Generate the email and send
        Set olMail = olApp.CreateItem(olMailItem)

        With olMail
            .To = rngRow.Cells(1,1).value 'Column A
            .Subject = "M&A Forum Event Sponseorship"
            .BodyFormat = olFormatHTML
            .Attachments.Add "C:\Users\User\Documents\Association\Event Brochure\BROCHURE.pdf"
            .HTMLBody = mail_body_message
            .Send

            'Instead of .send, consider using:
            '.Save
            '.Close
            'Then you'll have it as a draft and you can send from outlook directly
        End With        

    Next rngRow

    'Destroy the outlook application
    Set olApp = Nothing

End Sub