Excel 使用VBA自动发送outlook电子邮件

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

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

调试器会突出显示这一行代码

Set OutApp = CreateObject("Outlook.Application")

它说的是一个被阻挡的物体

如何在不重新启动outlook的情况下重复多次此操作？

有几个问题：

使用Destwb的第一个with语句

确实包含任何子方法，因此不需要使用它

错误转到0

-此错误处理已过时。阅读

请不要把你或其他人的电子邮件放在你的代码中…哈哈，我想我在修复你的代码后发送了一封意外的电子邮件

不管怎样，在这里

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

Dim FileExtStr作为字符串
Dim FileFormatNum尽可能长
将Sourcewb设置为工作簿
将WB设置为工作簿
Dim TempFilePath作为字符串
将文件名设置为字符串
Dim OutApp作为对象
将邮件变暗为对象
设置Sourcewb=ActiveWorkbook
活动表，收到
设置Destwb=ActiveWorkbook
如果Val（Application.Version）<12，则
FileExtStr=“.xls”：FileFormatNum=-4143
其他的
FileExtStr=“.xlsx”：FileFormatNum=51
如果结束
TempFilePath=Environ（“temp”）和“\”
TempFileName=“到期付款”格式（DateAdd（“m”，1，Now），“mmm-yyy”）
Set-OutApp=CreateObject（“Outlook.Application”）
Set-OutMail=OutApp.CreateItem（0）
用Destwb
出错时继续下一步
.SaveAs TempFilePath&TempFileName&FileExtStr，FileFormat:=FileFormatNum
如果错误号为0，则MsgBox“已获取文件名！”
发邮件
.To=”Fadel@wataniya.ps"
.CC=“”
.BCC=“”
.Subject=“到期付款”和格式（日期添加（“m”，1，现在），“mmm yyyy”）
.Body=“仅供参考”
.Attachments.Add Destwb.FullName
.发送
以
.Close savechanges:=False
以
发邮件，退出
发送邮件=无
设置应用程序=无
端接头

我使用以下方法，能够发送多封电子邮件而不会出现问题

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

---

在

设置OutApp=Nothing

之前，请尝试执行

OutApp。退出

。谢谢，但是在未重新启动outlook的情况下再次运行时仍然无法工作。那么，您是否正在更改每次加载的文件名？因为它每次都需要一个唯一的文件名。我刚刚尝试了同样的代码，并连续收到了两封来自我自己的电子邮件。仅供参考

Environ$（“temp”）

是完全可以接受的。试试看：）哦，酷！新玩具！：我的坏法德尔和大卫。将更新我的答案。我是否可以在代码中添加几行内容，以便在代码开始运行时打开outlook，然后关闭它或重新启动它或刷新它或其他内容？

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