Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Курилка
Страницы: 1
RSS
Outlook
 
#1
12.07.2014 09:47:40
Здрасте!
Спамером работаю недавно, поэтому прошу помощи.
Сбацал макрос (отдельное спасибо RAN за помощь - без него не стал бы спамером, так и остался бы неизвестно кем) рассылки с помощью Excel - Outlook.
Поскольку я начинающий и сразу не смог настроить Outlook 2013, воспользовался вот этой подсказкой для яндекс почты
все пошло нормально.
Попробовал на другом компе, с другим провайдером и пришлось установить Outlook 2003, ни чего другое не прокатило, настроил также.
Не идет не фига, письма попадают в Outlook, но не отправляются, подозреваю провайдера, но не уверен.
Может в 2003 есть какие-то свои нюансы?
Подскажите пожалуйста, очень хочется стать настоящим спамером.
 
 
 
#2
12.07.2014 10:11:11
я делал в обход outlook т.е. напрямую отправлял, как то так

Код
sub mail() 
adr =  "______@yandex.ru"  ' адрес вашего ящика
SaveSetting Application.Name, "mail", "smtpserver", "smtp.yandex.ru"    ' ??? SMTPServer
   SaveSetting Application.Name, "mail", "sendusername", adr   
   SaveSetting Application.Name, "mail", "sendpassword", "______________" ' пароль вашего ящика
   Dim FileN$
   On Error Resume Next
   txt = "Тело" & vbNewLine & _
          "2тело" 
adrTo = _________________ 'адреса получателей
    If Send_Mail(adrTo, adr, "Отчёт", txt) Then
        MsgBox "Отправлено", vbInformation
    Else
        MsgBox "Не отправлено", vbExclamation
    End If
   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
    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
   .Item(cdoConfigURL & "smtpserverport") = 465 
   .Item(cdoConfigURL & "smtpusessl") = 1  
   .Update
End With
MailAttachment = "C:\Temp\Общий" & Date & ".xls" 'вложение
    Set cdoMessage = CreateObject("CDO.Message")
    With cdoMessage
        Set .Configuration = cdoConfig
        .BodyPart.Charset = "koi8-r"
        .From = MailFrom:
        .To = MailTo
        .Subject = MailSubject
        .TextBody = MailText
        .addattachment MailAttachment
        .Send
    End With
    Set cdoMessage = Nothing: Set cdoConfig = Nothing
   Send_Mail = Err = 0
end function
Если очень захотеть - можно в космос полететь ;)
 
 
 
#3
12.07.2014 10:16:01
lexey_fan. спасибо.
хотелось бы воспользоваться своим макросом.
но если уж ни как не прокатит - попробую Ваш адаптировать.
 
 
 
#4
12.07.2014 10:41:24
Nic70y, а можете ваш показать?)
Если очень захотеть - можно в космос полететь ;)
 
 
 
#5
12.07.2014 10:53:19
запускается после проверки всякими другими макросами и формулами
Код
 Sub рассылка_2()
    Application.ScreenUpdating = 0
Dim objOL As Object
Dim objMail As Object
Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItem(0)
With objMail
'==============================================================================
'адрес получателя
.To = Cells(7, 11)
'==============================================================================
'текст письма
.Body = Cells(7, 14)
'==============================================================================
'тема письма
.Subject = Cells(2, 2)
'==============================================================================
'файл вложение (если есть - прикладываем)
    If [b4] <> "" Then
.Attachments.Add Cells(33, 11).Value
    End If
'==============================================================================
.Send
End With
Set objMail = Nothing
Set objOL = Nothing
End Sub
 
 
 
#6
20.07.2014 07:22:26
Заработало.
Не знаю в чем связь.
Удалил Avast, установил Касперского.
Microsoft Security на чужом компе ставить постеснялся  :/
 
 
 
Страницы: 1
Наверх