使用VBA自动发送Outlook电子邮件

Question

我将这段代码在Internet上的某个地方附加到代码末尾。 它复制所需的工作表，将其附加到电子邮件中，然后发送。

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的情况下重复多次？

Answer 1

一些问题：

1. 您的第一个with语句With Destwb确实包含任何子方法，因此不需要使用它。

2. On Error GoTo 0此错误处理已过时。 阅读“ To Err is Vbscript”

3. 请不要在您的代码中放入您的电子邮件或其他人的电子邮件...大声笑，我认为我在修复您的代码后发送了一封意外电子邮件。

无论如何，这是...

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

Answer 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