JekG
Silver Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код:
Sub SendMail() ' Отправка отчета по почте
txt = "Здравствуйте, Ольга!" & vbNewLine & _
If Send_Mail("XXX@gmail.com", "YYY@mail.ua", "Отчет СКД", txt) Then
MsgBox "Письмо успешно отправлено", vbInformation
Else
MsgBox "Не удалось отправить письмо", vbExclamation
End If
If Err.Number = 0 Then ' если операция отправки не вызвала ошибок - предполагаю, что где-то раньше встречается конструкция On Error Resume Next или подобный обработчик
Open ThisWorkbook.Path & "\log_report.txt" For Append As #1
Print #1, "Файл " & Filename & " успешно отправлен " & Now()
End If
End Sub
Function Send_Mail(ByVal MailTo As String, ByVal MailFrom As String, _
ByVal MailSubject As String, ByVal MailText As String, _
Optional ByVal MailAttachment As String = "") As Boolean
' функция для отправки почты без использования внешних почтовых программ
' ----------------------------------------------------------------------
' в качестве параметров получает:
' MailTo - адрес получателя письма
' MailFrom - адрес отправителя письма
' MailSubject - тема письма
' MailText - текст письма
' MailAttachment - полный путь к файлу вложения (необязательный параметр)
' ----------------------------------------------------------------------
' возвращает TRUE, если отправка почты произошла успешно, и FALSE в обратном случае
Dim TempFilePath As String
TempFilePath = "C:\Windows\Temp\" & ActiveWorkbook.Name & ".xls"
ActiveWorkbook.SaveCopyAs (TempFilePath)
Const cdoConfigURL = "http://schemas.microsoft.com/cdo/configuration/"
On Error Resume Next: Err.Clear
smtpserver = GetSetting(Application.Name, "mail", "smtpserver", "")
sendusername = GetSetting(Application.Name, "mail", "sendusername", "")
sendpassword = GetSetting(Application.Name, "mail", "sendpassword", "")
If Len(smtpserver) = 0 Or Len(sendusername) = 0 Or Len(sendpassword) = 0 Then Exit Function
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
.Item(cdoConfigURL & "sendusing") = 2
.Item(cdoConfigURL & "smtpauthenticate") = 1
.Item(cdoConfigURL & "smtpserver") = smtpserver
.Item(cdoConfigURL & "sendusername") = sendusername
.Item(cdoConfigURL & "sendpassword") = sendpassword
.Update
End With
Set cdoMessage = CreateObject("CDO.Message")
With cdoMessage
Set .Configuration = cdoConfig
.BodyPart.Charset = "koi8-r"
.From = MailFrom:
.To = MailTo
.Subject = MailSubject
.TextBody = MailText
.AddAttachment TempFilePath
.Send
End With
Set cdoMessage = Nothing: Set cdoConfig = Nothing
'Check that file exists
If Len(Dir$(TempFilePath)) > 0 Then
'First remove readonly attribute, if set
SetAttr TempFilePath, vbNormal
'Then delete the file
Kill TempFilePath
End If
' If Err.Number = -2147220973 Then MsgBox ("Отсутствует связь с интернетом")
' If Err.Number = -2147220975 Then MsgBox ("SMTP сервер ответил отказом")
' If Err.Number = 0 Then MsgBox ("Письмо отправлено")
Send_Mail = Err = 0
End Function
|
|
Всего записей: 2695 | Зарегистр. 12-10-2005 | Отправлено: 11:10 10-12-2010 | Исправлено: JekG, 11:19 10-12-2010 |
|
