[英]Out Of Memory generating emails via excel vba
我有一些在excel中運行的VBA代碼,該代碼可根據主題名稱生成電子郵件並將excel文件附加到電子郵件。 該宏似乎可以在101封電子郵件中正常運行,然后失敗,幾乎100%的時間。 每個附件為15kb,創建的電子郵件總數將有所不同,但是對於測試,我總共有128個。
實際的電子郵件組成是電子郵件的正文,帶有默認簽名,主題是靜態的,to是可變的。
我無法確定對代碼的任何修改,我每次迭代都將其放入OAMail Item,所以我有點不知所措(這是看似出錯的標准問題)。
代碼如下:
Sub Generate_Emails()
Dim OApp As Object
Dim OMail As Object
Dim signature As String
Dim emailbody As String
Dim ET As Worksheet
Dim Sum_WS As Worksheet
Dim EL As Worksheet
Dim CS As Worksheet
Set ET = ActiveWorkbook.Worksheets("EmailTemplate")
Set Sum_WS = ActiveWorkbook.Worksheets("Summary")
Set EL = ActiveWorkbook.Worksheets("EmailList")
Set CS = ActiveWorkbook.Worksheets("ControlSheet")
Set OApp = CreateObject("Outlook.Application")
'Check if emails can be generated
If CS.Range("F2") = "No" Then
MsgBox "Cannot generate files until Files have been generated", vbExclamation
Exit Sub
Else
i = Application.WorksheetFunction.CountA(EL.Range("A:A"))
body = ET.Range("A1")
'Go through each email in email list
For j = 2 To i
'Create email object
Set OMail = OApp.CreateItem(0)
'Get default signature
With OMail
.GetInspector
End With
'Allocate signature and body
signature = OMail.HTMLBody
'Create the whole email and add attachment
With OMail
.To = EL.Cells(j, 2)
.Subject = "SOx RemTP Audit " & Sum_WS.Range("C2")
.HTMLBody = body & vbNewLine & signature
.Attachments.Add Sum_WS.Range("B2") & "\SOx RemTP Audit " & Sum_WS.Range("C2") & " - " & EL.Cells(j, 1) & ".xlsx"
.Save
End With
Application.StatusBar = "Generating Email " & j & " of " & i
DoEvents
Set OMail = Nothing
Next j
Application.StatusBar = False
End If
Set OApp = Nothing
MsgBox "All emails placed into Outlook draft folder", vbInformation
End Sub
任何幫助將不勝感激。
干杯
一些注意事項:您的代碼看起來不錯,但使用Option Explicit
。
請參閱以'##
開頭的代碼中的注釋。
Option Explicit '## force proper variable declare to avoid typos and issues
Public Sub Generate_Emails()
Dim OApp As Object
Dim OMail As Object
Dim signature As String
Dim emailbody As String
Dim ET As Worksheet
Dim Sum_WS As Worksheet
Dim EL As Worksheet
Dim CS As Worksheet
Set ET = ActiveWorkbook.Worksheets("EmailTemplate")
Set Sum_WS = ActiveWorkbook.Worksheets("Summary")
Set EL = ActiveWorkbook.Worksheets("EmailList")
Set CS = ActiveWorkbook.Worksheets("ControlSheet")
Set OApp = CreateObject("Outlook.Application")
'Check if emails can be generated
If CS.Range("F2") = "No" Then
MsgBox "Cannot generate files until Files have been generated", vbExclamation
Exit Sub
Else
Dim i As Long '## dim i
i = Application.WorksheetFunction.CountA(EL.Range("A:A"))
emailbody = ET.Range("A1")
'Go through each email in email list
Dim j As Long '## dim j
For j = 2 To i
'Create email object
Set OMail = OApp.CreateItem(0)
'Get default signature
With OMail '## tidied up your with block (one is enough)
.GetInspector
'Allocate signature and body
signature = .HTMLBody
'Create the whole email and add attachment
.To = EL.Cells(j, 2)
.Subject = "SOx RemTP Audit " & Sum_WS.Range("C2")
.HTMLBody = emailbody & vbNewLine & signature
.Attachments.Add Sum_WS.Range("B2") & "\SOx RemTP Audit " & Sum_WS.Range("C2") & " - " & EL.Cells(j, 1) & ".xlsx"
.Save
.Close 0 '## close the mail to not leave it open (this might be the issue)
'0=olSave; 1=olDiscard; 2=olPromptForSave
End With
Application.StatusBar = "Generating Email " & j & " of " & i
DoEvents
'Set OMail = Nothing '## not needed
Next j
Application.StatusBar = False
End If
'Set OApp = Nothing '## not needed
MsgBox "All emails placed into Outlook draft folder", vbInformation
End Sub
幾乎不需要Set Something = Nothing
,因為VBA在End Sub
上自動執行此操作。
通過在With語句中添加“ .close 0”來解決問題。
原始循環:
'Go through each email in email list
For j = 2 To i
'Create email object
Set OMail = OApp.CreateItem(0)
'Get default signature
With OMail
.GetInspector
End With
'Allocate signature and body
signature = OMail.HTMLBody
'Create the whole email and add attachment
With OMail
.To = EL.Cells(j, 2)
.Subject = "SOx RemTP Audit " & Sum_WS.Range("C2")
.HTMLBody = body & vbNewLine & signature
.Attachments.Add Sum_WS.Range("B2") & "\SOx RemTP Audit " & Sum_WS.Range("C2") & " - " & EL.Cells(j, 1) & ".xlsx"
.Save
End With
Application.StatusBar = "Generating Email " & j & " of " & i
DoEvents
Set OMail = Nothing
Next j
在添加.close 0並與合並后,修改循環
'Go through each email in email list
For j = 2 To i
'Create email object
Set OMail = OApp.CreateItem(0)
'Get default signature
With OMail
.GetInspector
'Allocate signature
signature = OMail.HTMLBody
'Create the whole email and add attachment
.To = EL.Cells(j, 2)
.Subject = emailsubject
.HTMLBody = emailbody & vbNewLine & signature
.Attachments.Add attachmentsfolder & EL.Cells(j, 1) & ".xlsx"
.Save
.Close 0
End With
Application.StatusBar = "Generating Email " & j & " of " & i
DoEvents
Set OMail = Nothing
Next j
感謝Peh和Sam提供的解決方案
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.