vba - 电子邮件宏每 40 - 50 封电子邮件暂停一次

Question

我有一个半工作宏

循环浏览经理列表

为每个经理生成电子邮件正文

过滤与每个经理相关的所有数据表

将可见单元格转换为 HTML 表格

将表格添加到电子邮件

发送

问题是宏每 50 次迭代就停止生成电子邮件并且不会出错——它似乎只是“运行”而没有做任何事情。我已经手动停止了宏，并且没有一致的行似乎卡住了。尽我所能将其削减到裸露的骨头，但我不知道问题出在哪里。当我逐步完成时，我无法重现该问题。当我重新运行时，前 50 次运行正常，然后停止生成。
我也尝试添加 Application.Wait在每次循环迭代结束时调用并得到相同的问题
我最终不得不按 CTRL + BREAK 来停止宏。当我重新启动它的编码以从它停止的地方继续接收时，它会很好地发送下一批(这意味着当我再次开始时，它在运行时暂停的行会很好)。问题不是每隔一段时间 - 它会像时钟一样卡住。

宏开始(仅生成文本正文)

Sub Initiate()

    Dim EmailBody As String
    EmailBody = "HTML TEXT BODY HERE"

    Builder EmailBody     '<---- Call loop

End Sub

对经理执行循环并过滤其他工作表的相关数据。将所有范围传递给宏以构建电子邮件

Sub Builder(EmailBody As String)

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Distro List")
Dim Raw As Worksheet: Set Raw = ThisWorkbook.Sheets("Email Data")

Dim LR As Long, LR2 As Long
Dim EmailTable As Range, Target As Range, EmailRange As Range

LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set EmailRange = ws.Range("C2:C" & LR)
LR2 = Raw.Range("A" & Raw.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For Each Target In EmailRange
    If Target.Offset(, -2) = "y" Then
        If Len(Target.Offset(, -1)) = 6 Then
            If Right(Target.Offset(, 1), 7) = "@so.com" Or Right(Target.Offset(, 1), 11) = "@StackO.com" Then
            

                Raw.Range("A1:H" & LR2).AutoFilter 1, Target.Offset(, -1), VisibleDropDown:=False
                Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible).Columns.AutoFit
                Set EmailTable = Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible)
                            
                Sender EmailBody, EmailTable, Target
                        
                Set EmailTable = Nothing
            
            End If
        End If
    End If
Next Target

Application.ScreenUpdating = True

End Sub

建立电子邮件，调用 HTML 表格生成器宏，添加 HTML 表格，发送电子邮件

Sub Sender(EmailBody As String, EmailTable As Range, Target As Range)

Dim OutApp As Object
Dim OutMail As Object

On Error GoTo BNP:

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .SentOnBehalfOfName = "urdearboy@so.com"
            .to = Target.Offset(, 1)
            .Subject = "Your Employees....."
            .HTMLBody = "<p style = 'font-family:arial' >" _
                        & EmailBody & "</p>" _
                        & RangetoHTML(EmailTable) _
                        & "<p style = 'font-family:arial' >"
        
            .Send
            
            Target.Offset(, -2) = "Sent"
        End With
        
BNP:
    Set OutApp = Nothing
    Set OutMail = Nothing

End Sub

我在网上找到的宏可以将 excel 范围转换为可以插入电子邮件的 HTML 表格。

Function RangetoHTML(EmailTable As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    EmailTable.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

非常高兴，但也很恼火，说添加了 Applitcation.Wait 1 秒到函数 RangetoHTML解决了这个问题。

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile
    
    Application.Wait Now + #12:00:01 AM#                 '<------ Resolved Issue

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

仍然很想知道实际问题是什么，因为我怀疑这是解决实际问题的方法。很高兴我终于可以使用这个宏来发送大型发行版，而不会每 4 分钟暂停一次!