电子邮件宏每 40 - 50 封电子邮件暂停一次 [英] Email Macro Pauses every 40 - 50 emails
问题描述
我有一个半工作宏
- 遍历经理列表
- 为每位经理生成一个电子邮件正文
- 过滤与每位经理相关的所有数据表
- 将可见单元格转换为 HTML 表格
- 将表格添加到电子邮件
- 发送
问题是宏每 50 次迭代就会停止生成电子邮件并且不会出错 - 它只是看起来运行"了不做任何事情.我已经手动停止了宏，并且没有一致的行似乎卡住了.尽我所能将其削减到裸露的骨头，但我不知道问题出在哪里.当我逐步完成时，我无法重现该问题.当我重新运行时，前 50 次运行正常，然后停止生成.
The issue is the macro stops generating emails every 50 iterations in and does not error out - it just appears to "run" without doing anything. I have manually stopped the macro and there is no consistent line that appears to be getting stuck. Cutting this down to bare bones as much as I can, but I have no clue where the issue is. When I step through, I can't recreate the issue. When I re-run, the first 50ish go fine and then it stops generating.
我也尝试在每次循环迭代结束时添加 Application.Wait 调用并得到相同的问题
I have also tried adding Application.Wait call at the end of each loop iteration and get same issue
我最终不得不按 CTRL + BREAK 来停止宏.当我重新启动它的编码以从它停止的地方继续接收时，它会很好地发送下一批(这意味着当我再次开始时，它在运行时暂停的行会很好).问题不是偶尔出现 - 它会像时钟一样卡住.
I end up having to CTRL + BREAK to stop the macro. When I restart its coded to pick up right where it left off and it sends the next batch just fine (meaning the line it gets paused on runs just fine when I start again). Issue is not every once in a while - it's gets stuck like clock work.
宏开始(仅生成文本正文)
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
推荐答案
非常高兴，但也很恼火，说在 RangetoHTML<函数中添加一个 Applitcation.Wait 1 秒/code> 修复了问题.
Extremely glad, yet also annoyed, to say that adding a Applitcation.Wait for 1 second to the function RangetoHTML fixed the issue.
'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 分钟暂停一次！
Still curious to know what the actual issue is since I suspect that this is a work around to the actual issue. Just glad I can finally use this macro to send large distro's without it pausing every 4 minutes!
这篇关于电子邮件宏每 40 - 50 封电子邮件暂停一次的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
