通過Excel VBA發送電子郵件時發生錯誤-2147220975

Question

我在Excel Sheet中設置了一個按鈕，應該可以將工作表的圖片保存到硬盤中，然後將電子郵件發送到特定的地址連接到它的圖片，圖片的保存工作正常，但是當我嘗試和使用發送一段代碼，我發現在http://www.exceltoolset.com/sending-email-with-vba/電子郵件返回錯誤：-2147220975

這裏是整個子：

Sub SendKnap_Klik() 

    Set Sheet = ActiveSheet 
    Ret = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp")) 
    Output = Ret & "\SkemaSend.png" 

    zoom_coef = 100/Sheet.Parent.Windows(1).Zoom 
    Set area = Sheet.Range(Sheet.PageSetup.PrintArea) 
    area.CopyPicture xlPrinter 
    Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef) 
    chartobj.Chart.Paste 
    chartobj.Chart.Export Output, "png" 
    chartobj.Delete 

    ReturnValue = SendEMail("Subject", "MyMail@gmail.com", Range("J25").Value, "Body", "smtp.gmail.com", "", Output) 

    If ReturnValue = True Then 
     MsgBox "Emailen sent to " & Range("J25") & " was successfull!" 
    Else 
     MsgBox "Emailen sent to " & Range("J25") & " was not sent" & vbNewLine & "Error: " & Err.Number 
    End If 

End Sub 

Function SendEMail(Subject As String, _ 
     FromAddress As String, _ 
     ToAddress As String, _ 
     MailBody As String, _ 
     SMTP_Server As String, _ 
     BodyFileName As String, _ 
     Optional Attachments As Variant = Empty) As Boolean 

    Dim MailMessage As CDO.Message 
    Dim N As Long 
    Dim FNum As Integer 
    Dim S As String 
    Dim Body As String 
    Dim Recips() As String 
    Dim Recip As String 
    Dim NRecip As Long 

    ' ensure required parameters are present and valid. 
    If Len(Trim(Subject)) = 0 Then 
     SendEMail = False 
     Exit Function 
    End If 

    If Len(Trim(FromAddress)) = 0 Then 
     SendEMail = False 
     Exit Function 
    End If 

    If Len(Trim(SMTP_Server)) = 0 Then 
     SendEMail = False 
     Exit Function 
    End If 

    ' Clean up the addresses 
    Recip = Replace(ToAddress, Space(1), vbNullString) 
    If Right(Recip, 1) = ";" Then 
     Recip = Left(Recip, Len(Recip) - 1) 
    End If 
    Recips = Split(Recip, ";") 

    For NRecip = LBound(Recips) To UBound(Recips) 
     On Error Resume Next 
     ' Create a CDO Message object. 
     Set MailMessage = CreateObject("CDO.Message") 
     If Err.Number <> 0 Then 
      SendEMail = False 
      Exit Function 
     End If 
     Err.Clear 
     On Error GoTo 0 
     With MailMessage 
      .Subject = Subject 
      .From = FromAddress 
      .To = Recips(NRecip) 
      If MailBody <> vbNullString Then 
       .TextBody = MailBody 
      Else 
       If BodyFileName <> vbNullString Then 
        If Dir(BodyFileName, vbNormal) <> vbNullString Then 
         ' import the text of the body from file BodyFileName 
         FNum = FreeFile 
         S = vbNullString 
         Body = vbNullString 
         Open BodyFileName For Input Access Read As #FNum 
         Do Until EOF(FNum) 
          Line Input #FNum, S 
          Body = Body & vbNewLine & S 
         Loop 
         Close #FNum 
         .TextBody = Body 
        Else 
         ' BodyFileName not found. 
         SendEMail = False 
         Exit Function 
        End If 
       End If ' MailBody and BodyFileName are both vbNullString. 
      End If 

      If IsArray(Attachments) = True Then 
       ' attach all the files in the array. 
       For N = LBound(Attachments) To UBound(Attachments) 
        ' ensure the attachment file exists and attach it. 
        If Attachments(N) <> vbNullString Then 
         If Dir(Attachments(N), vbNormal) <> vbNullString Then 
          .AddAttachment Attachments(N) 
         End If 
        End If 
       Next N 
      Else 
       ' ensure the file exists and if so, attach it to the message. 
       If Attachments <> vbNullString Then 
        If Dir(CStr(Attachments), vbNormal) <> vbNullString Then 
         .AddAttachment Attachments 
        End If 
       End If 
      End If 
      With .Configuration.Fields 
       ' set up the SMTP configuration 
       .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server 
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 
       .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mymail@gmail.com" 
       .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "pass" 
       .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True 
       .Update 
      End With 

      On Error Resume Next 
      Err.Clear 
      ' Send the message 
      .Send 
      If Err.Number = 0 Then 
       SendEMail = True 
      Else 
       SendEMail = False 
       Exit Function 
      End If 
     End With 
    Next NRecip 
    SendEMail = True 
End Function 

我還更改了我的Gmail帳戶上的設置，以允許不安全的程序訪問帳戶

我做錯了什麼，應該改變什麼？

Answer 1

// 
// MessageId: CDO_E_SMTP_SEND_FAILED 
// 
// MessageText: 
// 
// The message could not be sent to the SMTP server. The transport error code was %2. The server response was %1 
// 
#define CDO_E_SMTP_SEND_FAILED   0x80040211L 

CDO將其作爲Windows Mail/Outlook Express/Microsoft Internet Mail和News的默認設置。

這VBA代碼列表配置：

Set emailConfig = emailObj.Configuration 
On Error Resume Next  
For Each fld in emailConfig.Fields 
    Text = Text & vbcrlf & fld.name & " = " & fld 
    If err.number <> 0 then 
     Text = Text & vbcrlf & fld.name & " = Error - probably trying to read password - not allowed" 
     err.clear 
    End If 
Next 
Msgbox Replace(Text, "http://schemas.microsoft.com", "")