excel - 使用 VBA 运行时问题批量发送电子邮件

Question

我已经编写了一个代码来动态发送批量电子邮件（名称，文档，到期日期，电子邮件地址将动态更改）..一切正常，但大约需要（4秒/邮件发送而不使用数组和2 秒 / 使用数组发送的邮件）...有人知道另一种方法可以让它更快一点吗？..在运行宏之前，请编辑.To =“您的电子邮件 ID”和密码..谢谢。发送 1000 封邮件大约需要 67 和 33 分钟。如果可能的话，我想让它 67 和 33 秒。这可能吗？如果过期日在今天起的 30/7/0 日之后，则会发送电子邮件。

过程 1

Public Sub SentRemainder()
Dim RemainingDay As Long, L As Integer, t1 As Long, t2 As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
t1 = Timer()
Dim lastrow As Long, i As Long
lastrow = Sheets("Personal").Cells(1048576, 2).End(xlUp).Row
With Sheets("Personal")
For i = 3 To lastrow
    If .Cells(i, 4).Value <> "" Then
         RemainingDay = .Cells(i, 4).Value - Now() + 1
    ElseIf .Cells(i, 4).Value = "" Then
       Exit For
    End If
    If RemainingDay = 30 Or RemainingDay = 7 Or RemainingDay = 0 Then
    SendEmailUsingGmail .Cells(i, 1).Value, .Cells(i, 2).Value, Format(.Cells(i, 4).Value, "DD-MMM-YYYY"), .Cells(i, 5).Value, RemainingDay
    L = L + 1
 '    ElseIf RemainingDay < 0 Then
 '        .Range(.Cells(i, "A"), .Cells(i, "E")).ClearContents
 '        .Range(.Cells(i, "A"), .Cells(lastrow - 1, "E")).Value = .Range(.Cells(i + 1, "A"), .Cells(lastrow, "E")).Value
'        .Range(.Cells(lastrow, "A"), .Cells(lastrow, "E")).ClearContents
End If
Next i
End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Email sent : " & L & "Nos."
t2 = Timer()
MsgBox "Time taken to run this code: " & t2 - t1

End Sub
'Enable Tools > References > Microsoft CDO for Windows 2000 Library
 Public Sub SendEmailUsingGmail(Name As String, Document As String, ExpiryDate As String, EmailAddress As String, RemainingDay As Long)
Dim NewMail As CDO.Message                                 'For Creating email collaboration.
Dim mailConfiguration As CDO.Configuration          'For mail configuration
Dim fields As Variant                                                 'For email field data.
Dim msConfigurationURL As String                           'For storing the server URL (CDO).
On Error GoTo Err:
    'early binding
    Set NewMail = New CDO.Message                          'Create the collaboration.
    Set mailConfiguration = New CDO.Configuration   'Create configuration.
    mailConfiguration.Load -1                                       'Load all default configurations
    Set fields = mailConfiguration.fields                        'Set configuration field to previous field.
    
    'Set All Email Properties
    With NewMail
        .From = "Your gmail address"            'From which email address email will be sent.
        .To = EmailAddress                                            'Where to send the email.
        .CC = ""                                                              'If you need to use CC then add email address.
        .BCC = ""                                                            'If you need to use BCC then add email address.
        .Subject = Document & " Expired in " & RemainingDay & " Day."    'Subject of Email..Dynamically it will change for every recepient.
                                                                                                       'For increasing readibility use _ .Here textbody is written.
        .TextBody = "Hi " & Name & "," & vbNewLine & _
        "Your " & Document & " will expire on " & ExpiryDate & _
        ".You have " & RemainingDay & " day to renew your " & Document & "." & "Please renew your " & Document & "." & _
        vbNewLine & "Thank You." & vbNewLine & "Md.Ismail Hosen"
        '.AddAttachment     'Here i need to edit.
    End With
    msConfigurationURL = "http://schemas.microsoft.com/cdo/configuration"           'For decrease word in below line.
    With fields
        .Item(msConfigurationURL & "/smtpusessl") = True                                         'Enable SSL Authentication
        .Item(msConfigurationURL & "/smtpauthenticate") = 1                                      'SMTP authentication Enabled
        .Item(msConfigurationURL & "/smtpserver") = "smtp.gmail.com"                     'Set the SMTP server details
        .Item(msConfigurationURL & "/smtpserverport") = 465                                     'Set the SMTP port Details....Check it in Gmail. Port may be 25/465/587
        .Item(msConfigurationURL & "/sendusing") = 2                                                'Send using default setting
        .Item(msConfigurationURL & "/sendusername") = "Your gmail address"        'Your gmail address
        .Item(msConfigurationURL & "/sendpassword") = "Your gmail password"                              'Your password or App Password(If 2F is on).
        .Update                                                                                                                             'Update the configuration fields
    End With
    With NewMail
        .Configuration = mailConfiguration                      'Set NewMail configuration to updated configuration.
        .Send
    End With
    'MsgBox "Your email has been sent", vbInformation
Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfiguration = Nothing
Exit Sub            'This is so much important if you want to run the sub multiple times.
Err:
Select Case Err.Number
Case -2147220973                                    'Could be because of Internet Connection
    MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975                                     'Incorrect credentials User ID or password
    MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case 0                              'Case 0 means code run smoothly and you need to exit this sub.
    GoTo Exit_Err:
Case Else                                                   'Report other errors
    MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select
Resume Exit_Err
End Sub

使用数组的过程 2：

Public Sub SentRemainder2()
Dim RemainingDay As Long, L As Integer, t1 As Long, t2 As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
t1 = Timer()
Dim i As Long

Dim arr As Variant
With Sheets("Personal")
arr = .Range(.Cells(3, 1), .Cells(.Cells(1048576, 2).End(xlUp).Row, 5)).Value
End With

Dim NewMail As CDO.Message                                 'For Creating email collaboration.
Dim mailConfiguration As CDO.Configuration          'For mail configuration
Dim fields As Variant                                                 'For email field data.
Dim msConfigurationURL As String                           'For storing the server URL (CDO).
On Error GoTo Err:
'early binding
Set NewMail = New CDO.Message                          'Create the collaboration.
Set mailConfiguration = New CDO.Configuration   'Create configuration.
mailConfiguration.Load -1                                       'Load all default configurations
Set fields = mailConfiguration.fields                        'Set configuration field to previous field.
msConfigurationURL = "http://schemas.microsoft.com/cdo/configuration"           'For decrease word in below line.
With fields
    .Item(msConfigurationURL & "/smtpusessl") = True                                         'Enable SSL Authentication
    .Item(msConfigurationURL & "/smtpauthenticate") = 1                                      'SMTP authentication Enabled
    .Item(msConfigurationURL & "/smtpserver") = "smtp.gmail.com"                     'Set the SMTP server details
    .Item(msConfigurationURL & "/smtpserverport") = 465                                     'Set the SMTP port Details....Check it in Gmail. Port may be 25/465/587
    .Item(msConfigurationURL & "/sendusing") = 2                                                'Send using default setting
    .Item(msConfigurationURL & "/sendusername") = "Your Gmail Address"        'Your gmail address
    .Item(msConfigurationURL & "/sendpassword") = "Your Gmail Password"                              'Your password or App Password(If 2F is on).
    .Update                                                                                                                             'Update the configuration fields
End With

For i = LBound(arr, 1) To UBound(arr, 1)
RemainingDay = arr(i, 4) - Now() + 1
If RemainingDay = 30 Or RemainingDay = 7 Or RemainingDay = 0 Then
    With NewMail
        .Configuration = mailConfiguration
        .From = "Your Gmail Address"            'From which email address email will be sent.
        .To = arr(i, 5)                                            'Where to send the email.
        .CC = ""                                                              'If you need to use CC then add email address.
        .BCC = ""                                                            'If you need to use BCC then add email address.
        .Subject = arr(i, 2) & " Expired in " & RemainingDay & " Day."    'Subject of Email..Dynamically it will change for every recepient.
                                                                                                       'For increasing readibility use _ .Here textbody is written.
        .TextBody = "Hi " & arr(i, 1) & "," & vbNewLine & _
        "Your " & arr(i, 2) & " will expire on " & arr(i, 4) & _
        ".You have " & RemainingDay & " day to renew your " & arr(i, 2) & "." & "Please renew your " & arr(i, 2) & "." & _
        vbNewLine & "Thank You." & vbNewLine & "Md.Ismail Hosen"
        '.AddAttachment     'Here i need to edit.
        .Send
    End With
        L = L + 1
    End If
Next i

Err:
Select Case Err.Number
Case -2147220973                                    'Could be because of Internet Connection
    MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975                                     'Incorrect credentials User ID or password
    MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case 0                              'Case 0 means code run smoothly and you need to exit this sub.
    GoTo Exit_Err:
Case Else                                                   'Report other errors
    MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select
Resume Exit_Err
Exit_Err:

'Release object memory
Set NewMail = Nothing
Set mailConfiguration = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Email sent : " & L & " Nos."
t2 = Timer()
MsgBox "Time taken to run this code: " & t2 - t1

End Sub

标签： excelvbacdo.message