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

Question

Я бизнес-майор с некоторыми минимальными знаниями VBA.

В моем университете я участвую в ассоциации. Раз в год мы ищем спонсоров для нашего крупнейшего мероприятия... и каждый раз, когда я делал это вручную. Проблема в том, что я могу только вручную отправлять по электронной почте так много директоров по маркетингу, и я могу также персонализировать электронные письма один за другим... поэтому мой поиск был ограничен.

Пока я немного не изучил VBA. Теперь я могу связаться с большим количеством людей... но Outlook отправляет электронные письма очень медленно.

Более того, мой ЦП находится на 15-20%, а мой 16G ОЗУ - на 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 в комментарий. Если вам абсолютно необходимо иметь возможность прервать выполнение кода во время его работы, тогда вы захотите сохранить 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