使用 VBA 的自动 Outlook 电子邮件答案

【问题标题】：Automatic outlook emails using VBA使用 VBA 的自动 Outlook 电子邮件
【发布时间】：2015-07-15 06:29:03
【问题描述】：

我在互联网某处找到了这段代码，附在代码的末尾。它复制所需的表格，将其附加到电子邮件中，然后发送。

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

Set Sourcewb = ActiveWorkbook

ActiveSheet.Copy
Set Destwb = ActiveWorkbook

With Destwb
    If Val(Application.Version) < 12 Then
    FileExtStr = ".xls": FileFormatNum = -4143
    Else
    FileExtStr = ".xlsx": FileFormatNum = 51
    End If
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
        .To = "Fadel@wataniya.ps"
        .CC = ""
        .BCC = ""
        .Subject = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy")
        .Body = "FYI"
        .Attachments.Add Destwb.FullName
        .Send
    End With
    On Error GoTo 0
    .Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

当我尝试再次运行代码（在同一个会话中）而不重新启动 Outlook 时，会弹出以下错误：

runtime error, 
automation error, 
system call failed,

并且调试器会高亮显示这行代码

Set OutApp = CreateObject("Outlook.Application")

它说明了一个被阻止的对象。

如何在不重新启动 Outlook 的情况下重复多次？

【问题讨论】：

在你 Set OutApp = Nothing 之前，尝试做 OutApp.Quit。

标签： excel vba email outlook

【解决方案1】：

几个问题：

您的第一个 with 语句 With Destwb 确实包含任何子方法，因此不需要使用它。
On Error GoTo 0 - 此错误处理已过时。阅读"To Err is Vbscript"
请不要将您或其他人的电子邮件放入您的代码中...大声笑我想我在修复您的代码后意外发送了一封电子邮件。

总之，就是这样……

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

Set Sourcewb = ActiveWorkbook

ActiveSheet.Copy
Set Destwb = ActiveWorkbook

If Val(Application.Version) < 12 Then
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    FileExtStr = ".xlsx": FileFormatNum = 51
End If

TempFilePath = Environ("temp") & "\"
TempFileName = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
    On Error Resume Next
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    If Err.Number <> 0 Then MsgBox "FileName Taken!"
    With OutMail
        .To = "Fadel@wataniya.ps"
        .CC = ""
        .BCC = ""
        .Subject = "Payments due in " & Format(DateAdd("m", 1, Now), "mmm-yyyy")
        .Body = "FYI"
        .Attachments.Add Destwb.FullName
        .Send
    End With
    .Close savechanges:=False
End With
OutMail.Quit
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

【讨论】：

谢谢，但在不重新启动 Outlook 的情况下再次运行时仍然无法正常工作。
嗯，您是否更改了每次加载的文件名？因为它每次都需要一个唯一的文件名。我刚刚尝试了相同的代码，并连续收到了我自己的 2 封电子邮件。
仅供参考Environ$("temp") 是完全可以接受的。试试看:)
太酷了！新玩具！ :D 我的坏法德尔和大卫。将更新我的答案。
我可以在代码中添加几行代码，在代码开始运行时打开 Outlook，然后关闭它或重新启动它或刷新它或其他什么？

【解决方案2】：

我使用以下内容并且能够毫无问题地发送多封电子邮件

sub sendEmail(varSubject, varBody, varTo, varCC)

Dim objOL 
Set objOL = CreateObject("Outlook.Application") 
If objOL Is Nothing Then
        Set objOL = CreateObject("Outlook.Application")
        objOL.Session.Logon "Outlook", , False, True
    End If
Dim objMsg 
Set objMsg = objOL.CreateItem(0) 
With objMSG 
    .Subject = varSubject & " Updated - " &Date
    .To = varTo
    .cc = varCC
    .Body = varBody
    .Send
End With

end sub

【讨论】：