Question

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

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

一些问题：

您的第一个语句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

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

使用VBA自动显示电子邮件

2 个答案: