Question

我在Excel工作表中设置了一个按钮，应该可以将工作表的图片保存到我的硬盘中，然后将电子邮件发送到附加图片的特定地址，保存图片工作正常，但当我尝试使用我在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", "")

通过Excel VBA发送电子邮件时出现错误-2147220975

1 个答案: