首页 文章

Out of Memory通过excel vba生成电子邮件

提问于
浏览 次
0

我有一些VBA代码，我在excel中运行，生成电子邮件并根据主题名称将excel文件附加到电子邮件中 . 对于101封电子邮件，宏似乎运行正常，然后几乎100％的时间都失败了 . 每个附件都是15kb，要创建的电子邮件总数会有所不同，但是对于测试我总共有128个 .

实际的电子邮件组成是电子邮件的正文，附加了默认签名，主题是静态的，并且是可变的 .

我无法识别代码所需的任何修改，我每次迭代都会丢弃到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

任何帮助将不胜感激 .

干杯

excel vba excel-vba email

2 回答

  • 0

    一些注意事项：您的代码看起来很好，但使用 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 上自动执行此操作 .

    回复于
  • 0

    通过在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提供解决方案

    回复于

相关问题