Функция для отправки почты без использования внешних почтовых программ

[Sprat]

Подскажите функцию для отправки почты без использования внешних почтовых программ в обход сервера http://schemas.microsoft.com/cdo/configuration/ (т.к. он в данный момент не работает)

[gluk_fm]

Может проблемы не с сервером а у Вас? У меня 10 сек. назад работало....

[Sprat]

Сообщение от gluk_fm

Может проблемы не с сервером а у Вас? У меня 10 сек. назад работало....

ну посмотри в чём может быть косяк

Sub Pochta()
Application.DisplayAlerts = False
SaveSetting Application.Name, "mail", "smtpserver", "smtp.mail.ru" ' Ваш SMTPServer
SaveSetting Application.Name, "mail", "sendusername", st_sprat@mail.ru ' Ваша учетная запись
SaveSetting Application.Name, "mail", "sendpassword", "*******" ' Ваш пароль
Application.DisplayAlerts = wdAlertsNone
Application.DisplayAlerts = wdAlertsAll

Folder = GetFolderPath
ReadFileNames (Folder)
Send_Mail "st_sprat@mail.ru", "st_sprat@mail.ru", "Программа открыта", txt, Workbooks("Test.xls").Sheets("Work" ).Cells(1, 1).Value
txt = "Проверка"
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 в обратном случае

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
If Len(MailAttachment) > 0 Then .AddAttachment MailAttachment
.Send
End With
Set cdoMessage = Nothing: Set cdoConfig = Nothing
Send_Mail = Err = 0
End Function


естественно вместо звёздочек ставлю свой пароль и почту отправлю от себя себеже

[gluk_fm]

Как по мне то что с этим кодом перемудрили, вот вариант попроще:
Sub imeil_items_send()
Dim dateFTP As String, mail As String, text_mail As String, ZipName As String
Dim objMsg As Object, Config As Object
dateFTP = Sheets("report").Range("B3").Value " дата
mail = "тема" & dateFTP " тема с датой
text_mail = "текст письма"
Application.DisplayAlerts = False
ZipName = "K:\CorpBank\MIS_report\General\FTP \FTP rate calculator.xls" "адрес файла
Set objMsg = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")
Set Config = objMsg.Configuration
objMsg.From = "от кого"
objMsg.To = "кому"
objMsg.Subject = mail
objMsg.TextBody = text_mail
objMsg.AddAttachment ZipName
Config("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Config("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "имя сервера"
Config("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
Config("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Config("http://schemas.microsoft.com/cdo/configuration/sendusername") = "имя"
Config("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "пароль"
Config.Fields.Update
objMsg.Send
End Sub

У меня работает без проблем уже больше года (только глюки когда забываю пароль сменить.)