Здравствуйте.
Нашел в инете макрос для отправки почты без помощи сторонних программ. Приспособил его под себя, заддав возможность аттачить к письму текущую книгу Excel.
Не могу реализовать такую штуку. Хотелось бы для самоконтроля добавить в этот макрос задание писать в текстовый документ (txt) созданный в папке с отправляемыми отчетами строку типа "Файл такой-то (имя файла) успешно отправлен такого-то числа"
И еще файлы у меня аттачатся почему-то с двойным расширением 06.12.2010.xls.xls. Как это исправить?
Sub SendMail() ' Отправка отчета по почте
txt = "Здравствуйте, Ольга!" & vbNewLine & _
"" & vbNewLine & _
"" & vbNewLine & _
"---------------------------" & vbNewLine & _
"С уважением Евгений"
If Send_Mail("xxx@gmail.com", "yyy@gmail.com", "Отчет СКД", txt) Then
MsgBox "Письмо успешно отправлено", vbInformation
Else
MsgBox "Не удалось отправить письмо", vbExclamation
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
