Отправка почты макросом Excel

[valerij]

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

с семерки не отправите...

Я же отправляю, правда Office 2003 Pro Rus.

[doober]

Видишь,как запутался.Я же помнил.что ты не смог отправлять.И человека ввел в заблуждение

[valerij]

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

Я же помнил.что ты не смог отправлять.

Да, было такое, но 7 не причем, все потом сам + все Ваши коды, разобрался и ОК!!!!

[valerij]

Не могу найти, что в коде удаляет макросы из файла, теперь надо, что бы на почту шел файл, полностью рабочий, со всеми, макросами, модулями..
Вот код

Private Sub SendAttachment()
c = Day(Date)
    If Not IsDate(Лист1.Cells(2, c * 2 - 1)) Then
       MsgBox "Ячейка C3 не содержит даты", vbCritical, ""
       Exit Sub
    End If
    iFileName$ = ThisWorkbook.Path & "\" & _
    "УчетА на " & Format(Лист1.Cells(2, c * 2 - 1), "dd/mm/yy") & ".xls"
    vArray = Array("", "xxxx@yandex.ru")
    With Application
         .ScreenUpdating = False
         .DisplayAlerts = False
         .EnableEvents = False
         For iCount% = 1 To 1 '2 'UBound(vArray)
             With ThisWorkbook.Worksheets(iCount%)
                  .Cells.Copy: iManufactura$ = .Name
             End With
             With Workbooks.Add(xlWBATWorksheet)
                  With .Worksheets(1)
                       .Name = iManufactura$
                       .Cells.PasteSpecial Paste:=xlValues
                       .Cells.PasteSpecial Paste:=xlFormats
                       .Cells(1).Select
                       .Protect Password:=ChildPassword(10)
                  End With
                  .Windows(1).DisplayHeadings = False
                  .Close saveChanges:=True, Filename:=iFileName$
             End With
        
             If Send_Mail(vArray(iCount%), _
                "yyyyy@yandex.ru", "Учет-Авто", iFileName$) Then
                MsgBox "Письмо успешно отправлено", vbInformation, ""
             Else
                MsgBox "Не удалось отправить письмо", vbExclamation, ""
             End If
             Kill PathName:=iFileName$
         Next
         .EnableEvents = True
         .DisplayAlerts = True
         .ScreenUpdating = True
    End With
End Sub
Private Function ChildPassword$(LenPassword%)
    Randomize 'Timer
    ChildPassword$ = Space(LenPassword)
    For iCount% = 1 To LenPassword
        Mid(ChildPassword$, iCount%, 1) = Chr(Rnd * 255)
    Next
End Function

[EducatedFool]

Не могу найти, что в коде удаляет макросы из файла

и не найдёшь

этот код создаёт новый файл, в который копирует содержимое ячеек текущего файла.
(макросы при этом не копируются)

[valerij]

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

(макросы при этом не копируются)

Понял, спасибо, придется все заново, штудировать.

[valerij]

Если кому надо, вот готовый код для отправки книги со всеми макросами, данными, работает из под W7 и XPSP3
Два модуля
Модуль 1

Function Send_Mail(ByVal MailTo As String, _
                   ByVal MailFrom As String, _
                   ByVal MailSubject As String, _
                   ByVal MailAttachment As String, _
                   Optional ByVal MailText As String = "") As Boolean
    Const cdoConfigURL = "http://schemas.microsoft.com/cdo/configuration/"
    Const SmtpServer = "smtp.yandex.ru"
    Const SendUsername = "адрес отправителя"
    Const SendPassword = "его пароль"
    On Error Resume Next
    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 MailAttachment
        .Send
    End With
    Set cdoMessage = Nothing: Set cdoConfig = Nothing
    Send_Mail = (Err.Number = 0)
End Function

Модуль 2

Private Sub SendAttachment()
    Dim iCell As Range
    Set iCell = Лист1.Cells(2, Day(Date) * 2 - 1)
    If Not IsDate(iCell) Then
       MsgBox "Ячейка " & iCell.Address & " не содержит даты", vbCritical, ""
       Exit Sub
    End If
    
    Application.DisplayAlerts = False
    
    iFileName$ = ThisWorkbook.Path & _
    "\УчетА на " & Format(iCell.Value, "dd/mm/yy") & ".xls"
    ThisWorkbook.SaveCopyAs Filename:=iFileName$
        
    If Send_Mail("адрес получателя", "адрес отправителя", "Учет-Авто", iFileName$) Then
       MsgBox "Письмо успешно отправлено", vbInformation, ""
    Else
       MsgBox "Не удалось отправить письмо", vbCritical, ""
    End If
    Kill PathName:=iFileName$
         
    Application.DisplayAlerts = True
End Sub

Если не надо менять имя файла, то
Модуль 2

Private Sub SendAttachment()
    Application.DisplayAlerts = False
        iFileName$ = ThisWorkbook.Path & "\ Имя Файла.xls"
            ThisWorkbook.SaveCopyAs Filename:=iFileName$
    If Send_Mail("адрес получателя", "адрес отправителя", _
            "Название темы письма", iFileName$) Then
       MsgBox "Письмо успешно отправлено", vbInformation, ""
    Else
       MsgBox "Не удалось отправить письмо", vbCritical, ""
    End If
        Kill PathName:=iFileName$
    Application.DisplayAlerts = True
End Sub

Причем, адрес получателя, может = адрес отправителя
т. е. один и тот же адрес, удобно(в моем случае)

[sasha_prof]

Подскажите плиз, как отправить задачу?

[EducatedFool]

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

Подскажите плиз, как отправить задачу?

А что такое "задача" в вашем понимании?

[sasha_prof]

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

А что такое "задача" в вашем понимании?

Ссори.
В АУТЛУКЕ в закладке создать есть - "Встреча", "Задача" и т.д.
Вот это я и имел ввиду