使用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