使用 VBA 自动 Outlook 电子邮件
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22642531/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Automatic outlook emails using VBA
提问by F.Naim
I have this code I found somewhere over the internet attached to the end of my code. It copies the needed sheet, attaches it to an email and then sends it.
我有这个代码，我在互联网上的某个地方找到了附加到我的代码末尾。它复制所需的工作表，将其附加到电子邮件中，然后发送。
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 = "[email protected]"
.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
When I try to run the code again (in the same session) without restarting Outlook the following error pops up:
当我尝试在不重新启动 Outlook 的情况下再次运行代码（在同一会话中）时，会弹出以下错误：
runtime error,
automation error,
system call failed,
and the debugger highlights this line of the code
并且调试器突出显示这行代码
Set OutApp = CreateObject("Outlook.Application")
and it says something about a blocked object.
它说明了一些有关被阻止对象的信息。
How can I repeat this multiple times without restarting outlook ?
如何在不重新启动 Outlook 的情况下多次重复此操作？
回答by Rich
A few problems:
几个问题：
Your first with statement
With Destwbdid contain any submethods, so it doesn't need to be used.On Error GoTo 0- This error handling is Obsolete. Read "To Err is Vbscript"Please don't put yours or someone elses email in your code...lol I think i sent an accidental email after I repaired your code.
您的第一个 with 语句
With Destwb确实包含任何子方法，因此不需要使用它。On Error GoTo 0- 此错误处理已过时。阅读“错误是 Vbscript”请不要将您或其他人的电子邮件放入您的代码中...lol 我想我在修复您的代码后意外发送了一封电子邮件。
Anyways, here it is....
不管怎样，这里是......
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 = "[email protected]"
.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
回答by Ken
I use the following and am able to send multiple emails without issue
我使用以下内容并且能够毫无问题地发送多封电子邮件
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
