Страницы: 1
RSS
Макрос рассылки писем
 
Тема поднималась сотни раз.
Но я пока не нашел идеальный вариант для себя  :)  
В инете нашел такой вот код на рассылку писем с Excel, немного подстроил для своих диапазонов
Но, пока не работает
Подозреваю что возможно проблема в строке  For i = 1 To addrcount
Подскажите, как исправить макрос?


Скрытый текст
 
Цитата
googlogmob пишет: Подозреваю что возможно проблема в строкеFor i = 1 To addrcount
Что такое addrcount?
Согласие есть продукт при полном непротивлении сторон
 
в предыдущем коде был переменной.
не могу понять, какое значение нужно вписатиь в эту строку вместо addrcount
 
sTo = Range("A2:A3" ) .Value
это неправильно. Надо содавать массив и как массиву и обращаться.
Код
Sub mailing()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    asTo = Range("A2:A3").Value
    asSubject = Range("B2:B3").Value
    asBody = Range("C2:C3").Value
    asAttachment = Range("D2:D3").Value

    For i = 1 To UBound(asTo, 1)
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo(i, 1)
            .Subject = asSubject(i, 1)
            .body = asBody(i, 1)
            .Attachments.Add asAttachment(i, 1)
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next i

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
Не проверял, но должно работать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
The_Prist, работает)
Спасибо
 
Здравствуйте, использую существующий макрос рассылки писем, но что-то не так.. на сколько я понимаю проблема во вложении к письму (да и письмо без вложения приходит..) вообщем прошу Вашей помощи.


Код
Sub file_backup_save_notribbon()
    ' Макрос создания резервной копии текущего файла. Архивация файла осуществляется средствами Windows
    ' Чтобы макрос обрабатывал активную книгу - замените в коде все ThisWorkbook на ActiveWorkbook
    Const PROJECT_NAME = "РСД_по_состоянию_на_"    ' название вашей программы (любой текст)
    On Error Resume Next

    ' формируем путь к папке, куда будет помощена копия файла (в виде архива)
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "_Архив\")
    MkDir BackupsPath    ' создаём папку, если таковой ещё нет

    ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, ".")))    ' расширение файла
    ' формируем путь для копии файла Excel
    FileNameXls = BackupsPath & PROJECT_NAME & Format(Now, "YYYY-MM-DD_HH-NN-SS") & "." & ext$
    ' формируем путь для создаваемого архива ZIP
    FileNameZip = BackupsPath & PROJECT_NAME & Format(Now, "YYYY-MM-DD_HH-NN-SS") & ".zip"

    ThisWorkbook.SaveCopyAs FileNameXls    ' создаём копию книги
    ZIPresult = Zip_File(FileNameXls, FileNameZip, True)    ' упаковываем копию книги в архив ZIP

    MsgBox "Результат архивации: " & IIf(ZIPresult, "выполнено успешно ", "ошибка ") & _
    "Создан архив: " & Chr(13) & _
    Dir(FileNameZip), vbOKOnly
End Sub

Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _
    Optional ByVal DeleteSourceFile As Boolean = False) As Boolean
    ' Функция осуществляет упаковку файла FileNameXls в архив с именем FileNameZip
    ' если DeleteSourceFile = TRUE, исходный файл FileNameXls удаляется по окончании архивации
    ' Возвращает TRUE, если архивация завершилось удачно, и FALSE в противном случае
    On Error Resume Next: Err.Clear:
    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
    If Len(Dir(FileNameXls)) = 0 Then MsgBox "Файл """ & FileNameXls & """ не найден!", _
       vbCritical, "Ошибка в функции Zip_File": Exit Function

    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameZip).CopyHere FileNameXls    'копируем файл в сжатую папку

    Do Until oApp.Namespace(FileNameZip).Items.Count = 1    'ждём завершения упаковки файла
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop

    If DeleteSourceFile Then Kill FileNameXls    ' удаляем временно созданный файл
    Zip_File = Err = 0    ' возвращаем результат упаковки (TRUE, если всё завершилось удачно)
End Function


Sub file_backup_sendmail()

    Call file_backup_save_notribbon ' Сначала делаем и архивируем копию файла
    
    Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
    Dim oCDOCnf As Object, oCDOMsg As Object
    Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
    Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String
    On Error Resume Next
    'sFrom – как правило совпадает с sUsername
    SMTPserver = "smtp.mail.ru"    ' SMTPServer: для Mail.ru "smtp.mail.ru"; для Яндекса "smtp.yandex.ru"; для Рамблера "mail.rambler.ru"
    sUsername = "ОБРАЗЕЦ@mail.ru"    ' Учетная запись на сервере
    sPass = "ОБРАЗЕЦ"    ' Пароль к почтовому аккаунту

    If Len(SMTPserver) = 0 Then MsgBox "Не указан SMTP сервер", vbInformation, "Сервис отправки писем": Exit Sub
    If Len(sUsername) = 0 Then MsgBox "Не указана учетная запись", vbInformation, "Сервис отправки писем": Exit Sub
    If Len(sPass) = 0 Then MsgBox "Не указан пароль", vbInformation, "Сервис отправки писем": Exit Sub
 
    sTo = "ОБРАЗЕЦ@live.ru"    'Кому
    sFrom = "ОБРАЗЕЦ@mail.ru"    'От кого
    sSubject = "Проверка сервиса"    'Тема письма
    sBody = "Письмо сформировано автоматически, на него отвечать не нужно."    'Текст письма
    sAttachment = FileNameZip    'Вложение (полный путь к файлу)
    'Проверка наличия файла по указанному пути
    If Dir(sAttachment, vbDirectory) = "" Then sAttachment = ""
    'Назначаем конфигурацию CDO
    Set oCDOCnf = CreateObject("CDO.Configuration")
    With oCDOCnf.Fields
        .Item(CDO_Cnf & "sendusing") = 2
        .Item(CDO_Cnf & "smtpauthenticate") = 1
        .Item(CDO_Cnf & "smtpserver") = SMTPserver
        .Item(CDO_Cnf & "sendusername") = sUsername
        .Item(CDO_Cnf & "sendpassword") = sPass
        .Update
    End With
    'Создаем сообщение
    Set oCDOMsg = CreateObject("CDO.Message")
    With oCDOMsg
        Set .Configuration = oCDOCnf
        .BodyPart.Charset = "koi8-r"
        .From = sFrom
        .To = sTo
        .Subject = sSubject
        .TextBody = sBody
        If Len(sAttachment) > 0 Then .AddAttachment sAttachment
        .Send
    End With
 
    Select Case Err.Number
    Case -2147220973: sMsg = "Нет доступа к Интернет"
    Case -2147220975: sMsg = "Отказ сервера SMTP"
    Case 0: sMsg = "Письмо отправлено"
    End Select
    MsgBox sMsg, vbInformation, "Сервис отправки писем"
    Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
End Sub
 
Где объявлена FileNameZip?
Через F8 не пробовали посмотреть, что Вы вкладываете в письмо?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
В макросе file_backup_save_notribbon, не объявлена но используется переменная FileNameZip, всё заработало когда я макрос file_backup_save_notribbon внедрил в file_backup_sendmail, а не вызывал его с помощью оператора Call. Видимо так переменная остаётся в памяти, а после использования в file_backup_save_notribbon обнуляется.. что ли..  :)
Изменено: Сливочный - 20.07.2014 10:49:16
 
А я вопрос не просто так задал :-)
Если почитаете, поймете, что можно было просто объявить переменную на уровне модуля или проекта и все бы так же работало.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Здравствуйте, использовал данный макрос, ну тоже самое, что и выше. Почта отправляется нормально, но отчет о доставке и прочтении не приходит.
Использовал этот код с сайта microsoft для формирования отчета:
Код
.fields("urn:schemas:mailheader:disposition-notification-to") = "<valid e-mail address>" 'ToDo: Type a valid e-mail address.
    .fields("urn:schemas:mailheader:return-receipt-to") = "<valid e-mail address>"  'ToDo: Type a valid e-mail address.
    
    'Set DSN options.
'    Name                   Value       Description
'    cdoDSNDefault             0       No DSN commands are issued.
'    cdoDSNNever               1       No DSN commands are issued.
'    cdoDSNFailure             2       Return a DSN if delivery fails.
'    cdoDSNSuccess             4       Return a DSN if delivery succeeds.
'    cdoDSNDelay               8       Return a DSN if delivery is delayed.
'    cdoDSNSuccessFailOrDelay  14      Return a DSN if delivery succeeds, fails, or is delayed.

    .DSNOptions = cdoDSNSuccessFailOrDelay
    .DSNOptions = 14
    .fields.update
Кому-нибудь удалось добиться получать отчеты о доставке и прочтении писем?
Страницы: 1
Наверх