Question

我有一个Excel宏，用于创建自定义图表，打开Outlook邮件模板，替换某些文本，添加自定义图表，然后将其发送。

我的目的是每次运行宏时发送大约50,000封电子邮件。但在我遇到错误之前，我只能通过大约3,000到5,000：＆＃34;没有足够的内存来完成此操作。尝试使用较少的数据或关闭其他应用程序要提高内存可用性，请考虑使用64位版本的Microsoft Excel。＆＃34;

代码在开始时工作正常，每秒发送大约1封电子邮件。事实上，它起初非常顺利。然后，当它进入数百甚至数千时，它会大幅减速。在崩溃之前和崩溃期间，我可以从任务管理器中看到，只有10％的CPU和15％的RAM正在被利用 - 我认为不足以引起这样的内存问题。

当我收到错误时，我通常保存并关闭Excel，重新打开工作簿，然后再次运行正常。所以我输入了一些代码，每1000封电子邮件停止一次，然后在继续之前保存工作簿。这根本没有帮助。

我还以为可能是Outlook发件箱被堵塞了。在某些情况下，我确实看到发件箱中有500多条未发送的消息。所以我输入了一些代码来检查以确保发件箱文件夹在发送之前有0或1条消息。虽然我对堵塞的发件箱没有任何问题，但这仍然无法解决内存问题。

关于我的系统和设置的几点说明：

我在具有64 GB RAM的专用Windows 2016服务器上运行此操作（确切的服务器规格在此处：https://turnkeyinternet.net/dedicated-servers/dedicated-server-dual-hexacore-64gb/）
我正在运行64位Excel 2016
当我尝试运行此宏时，没有其他程序正在运行（除了其他必要的后台进程，当然还有Outlook会话）
我已禁用所有COM加载项，Excel加载项和Outlook加载项
我将计算设置为手动

有没有人对如何缓解这个问题有任何想法？如果我的解释不完全清楚，我很乐意提供任何其他细节。代码如下：

Sub EMAILER()

'Turning off non-essential functions
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

'Counting how many rows of data in the Import sheet (corresponding to how many emails are sent)
Dim lngRow As Long
lngRow = Worksheets("Import").Cells(Rows.Count, "A").End(xlUp).Row

'Variables to operate the macro
Dim Counter As Integer

'Variables to sub into the template
Dim DataField1 As String
Dim DataField2 As String
Dim DataField3 As String
Dim TimeOfDayGreeting As String
Dim Recipient As String

'Variables to create and copy the custom chart
Dim DataObj As Shape
Dim objChart As chart
Dim folderpath As String
Dim picname As String
Dim ws As Worksheet
Dim chart As Picture

'Variables to create and open an Outlook session and the template email
Dim oApp As Object, oMail As Object

'Variables to Find & Replace in the template
Dim strFind As String
Dim strNew As String
Dim imgSrc As String

'Variables to check that the outbox isn't clogged
Dim OutboxCount As Integer

'Data starts at row 2, below headers... Goes to the last row of the sheet
For Counter = 2 To lngRow

'Before the first email, checks the time and then sets the greeting accordingly
If Counter = 2 Then
    If Hour(Now) >= 12 And Hour(Now) < 18 Then TimeOfDayGreeting = "afternoon" Else
    If Hour(Now) >= 18 Or Hour(Now) < 4 Then TimeOfDayGreeting = "evening" Else
    If Hour(Now) >= 4 And Hour(Now) < 12 Then TimeOfDayGreeting = "morning" Else
End If

'Every 500 rows/emails, save the workbook and check the time again to set the greeting again
If Counter Mod 500 = 0 Then
    ActiveWorkbook.Save
    If Hour(Now) >= 12 And Hour(Now) < 18 Then TimeOfDayGreeting = "afternoon" Else
    If Hour(Now) >= 18 Or Hour(Now) < 4 Then TimeOfDayGreeting = "evening" Else
    If Hour(Now) >= 4 And Hour(Now) < 12 Then TimeOfDayGreeting = "morning" Else
End If

'Pulls the values from their cells in the Import sheet
DataField1 = Worksheets("Import").Cells(Counter, 24)
DataField2 = Worksheets("Import").Cells(Counter, 1)
DataField3 = Worksheets("Import").Cells(Counter, 5)
Recipient = Worksheets("Import").Cells(Counter, 17)

'Pastes the values from into the Chart sheet to create the custom chart
Worksheets("Chart").Cells(1, 2) = DataField1
Worksheets("Chart").Cells(2, 2) = DataField2
Worksheets("Chart").Cells(6, 2) = DataField3

'Updates the chart area, since calculation is set to manual mode
Worksheets("Chart").Columns("A:J").Calculate

Set ws = Worksheets("Chart")

'Locating & assigning current folder path of Excel file, then setting the name for the chart image based on DataField1
folderpath = Application.ActiveWorkbook.Path & Application.PathSeparator
picname = DataField1 & ".jpg"

'Copying the chart range as an image
ActiveWindow.DisplayGridlines = False
On Error GoTo ErrHandler3:
Call ws.Range("H6:AB26").CopyPicture(xlPrinter, xlPicture)

'Creates a new sheet called Image, then adds the chart image, sets the height/width, then exports it to the folder with its name
Worksheets.Add(after:=Worksheets(1)).Name = "Image" 'creating a new sheet to insert the chart
ActiveSheet.Shapes.AddChart.Select
Set objChart = ActiveChart
ActiveSheet.Shapes.Item(1).Width = ws.Range("H6:AB26").Width 'making chart size match image range size
ActiveSheet.Shapes.Item(1).Height = ws.Range("H6:AB26").Height
objChart.Paste
objChart.Export (folderpath & picname) 

'Deletes the Image sheet
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete 'deleting sheet 'Image'
Application.DisplayAlerts = True


'Opens an Outlook session
Set oApp = CreateObject("Outlook.Application")

'Opens the template from the from its folder
Set oMail = oApp.CreateItemFromTemplate("C:\Users\Administrator\EMAILER\TEMPLATE.oft")

With oMail

'Adds the custom chart (saved as an image) to the email template
.Attachments.Add "C:\Users\Administrator\EMAILER\" & DataField1 & ".jpg", olByValue, 0

    .To = Recipient
    .Subject = DataField1

'Find and replace placeholders in the template including: Greeting, Chart, and Data Fields 1, 4, and 5 (4 and 5 are not defined as variables)
    strFind = "[GREETING]"
    .HTMLBody = Replace(oMail.HTMLBody, strFind, TimeOfDayGreeting)

    strFind = "[PASTE CHART HERE]"
    strNew = "<img src='cid:replace.jpg' width='894' heigth='300'"
    strNew = Replace(strNew, "replace", DataField1)
    .HTMLBody = Replace(oMail.HTMLBody, strFind, strNew)

strFind = "[DATAFIELD1]"
    strNew = DataField1
    .HTMLBody = Replace(oMail.HTMLBody, strFind, strNew)

    strFind = "[DATAFIELD4]"
    strNew = Format(Worksheets("Import").Cells(Counter, 41), "#,##0")
    .HTMLBody = Replace(oMail.HTMLBody, strFind, strNew)

    strFind = "[DATAFIELD5]"
    strNew = Format(Worksheets("Import").Cells(Counter, 37), "#,##0")
    .HTMLBody = Replace(oMail.HTMLBody, strFind, strNew)


'Check that outbox has 1 or less messages. Waits 1 second if outbox has 2 or more messages, then checks again until it has 1 or less.
OutboxCountStep:
    OutboxCount = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox).Items.Count
    If OutboxCount > 1 Then
        Application.Wait (Now + TimeValue("00:00:01"))
        GoTo OutboxCountStep:
    End If

    'I don't want to keep a copy of the message in my Sent mailbox, then send it off.
    .DeleteAfterSubmit = True
    .Send

    End With

Next Counter

'Turn back on essential functions
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

'Send myself an email to let me know that its finished (I never get to this part)
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItemFromTemplate("C:\Users\Administrator\EMAILER\DONE.oft")
oMail.Send

MsgBox "Done"

End Sub

Answer 1

将DoEvents代码放入for循环中几次。

https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/doevents-function

这应该允许你的处理器执行一些任务，它会让你的代码花费更长的时间但是应该避免完全的内存情况：）

Answer 2

将Set oApp = CreateObject("Outlook.Application")放在For循环之外。

Answer 3

我一直无法找到解决内存泄漏的解决方案，所以我改用PHP而不是excel来生成图表。

Excel VBA - 通过Outlook发送电子邮件 - 没有足够的内存来完成此操作

3 个答案: