Я установил кнопку в своем листе Excel, которая должна иметь возможность сохранять изображение листа на моем жестком диске, а затем отправлять электронную почту на конкретный адрес с помощью изображение прилагается к нему, экономия картины работает отлично, но когда я пытаюсь отправить электронную почту, используя кусок кода, который я нашел в http://www.exceltoolset.com/sending-email-with-vba/ он возвращает ошибку: -2147220975Ошибка -2147220975 при отправке электронной почты с помощью Excel VBA
Здесь весь суб:
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", "[email protected]", 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") = "[email protected]"
.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, чтобы разрешить незащищенным программам доступ к учетной записи
Что я делаю неправильно, нужно что-то изменить?
Какая линия вы получите ошибку? – ZygD
Я не получаю ошибку в какой-либо строке, но как код ошибки «SendEMail» возвращается, поскольку он не работает – Awlaursen
Я исправил его сам, при этом настройки в google не были сохранены – Awlaursen