Отправка файла через Outlook при условии его нахождения в папке

[Gvaridos]

Всем доброго времени суток!

Помогите с макросом: необходимо каждый день в 16-00 идти по заданному пути (\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229) и искать там файл за сегодняшнюю дату.
Формат файла который ищем: m 3173-229 26.11.10.xls (то есть m 3173-229 "текущая дата".xls)
Если файл есть - отправляем его точно по адресу (например 123@yandex.ru)
Если файла нет, находим последнюю пустую строчку на листе откуда происходил макрос и пишем "m 3173-229 26.11.10.xls не найден"
Помогите пожалуйста!!!

[doober]

Код разместите в модуле книги

Const F_path As String = "\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\"
Const F_NM As String = "m 3173-229 "

Private Sub Workbook_Open()
 M_Tim
End Sub


Sub Mail()
Dim F_Name As String
F_Name = Dir(F_path & F_NM & Date & ".xls")
If Len(F_Name) > 0 Then
     Dim OutApp As Object
    Dim OutMail As Object
   Application.EnableEvents = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = "123@yandex.ru"
                .CC = ""
                .Subject = "Testfile"
                .Body = "Привет"
                 .Attachments.Add F_Name
                .Display
            End With
            Set OutMail = Nothing
    Set OutApp = Nothing
  Application.EnableEvents = True
Else
 Dim Kl
     Kl = Sheets(1).UsedRange.Rows.Count
     Sheets(1).Cells(Kl + 1, 1) = F_NM & Date & ".xls" & " не найден"
End If
End Sub


Sub M_Tim()
If Second(Now) = 0 And Minute(Now) = 0 And Shour(Now) = 16 Then
Mail
End If
NextTick = Now + TimeValue("00:01:00")
Application.OnTime NextTick, "M_Tim"
If Second(Now) = 0 Then
Else
NextTick = Now + TimeValue("00:01:00") - TimeSerial(0, 0, Second(Time))
End If
End Sub

[Gvaridos]

Спасибо огромное!!!
Только можно вас попросить внести небольшие поправки?
1) Дата не сегодняшняя а предыдущего дня.
Т.е. если сегодня 26.11.2010, то мы ищем и отправляем файлик с датой 25.11.2010

2)Можно ли попровать, чтобы каждый понедельник он отнимал от даты 3 дня, т. е. искал и отправлял документ за пятницу (т.к. сб и вс - выходные)?
Заранее спасибо!

[IgorGO]

или так:

Sub SendReport()
  pt = "\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\"
  fn = "m 3173-229 " & Format(Now, "DD.MM.YY") & ".xls"
  On Error Resume Next
  Application.DisplayAlerts = False
  Workbooks.Open pt & fn
  If Err.Number > 0 Then
    Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = fn & " - не найден, ошибка:" & Err.Number
  Else
    ActiveWorkbook.SendMail "igorgo@ukr.net", "тема"
    ActiveWorkbook.Close
  End If
  Application.DisplayAlerts = True
End Sub

есть тут одна проблема, даже если это выполнить в 16:00 (как - Сергей написал). У меня почтовик - OutLook, он выбрасывает окно "Разрешить отсылку???" и ничего не произойдет дальше, пока не указать что же делать дальше.

Кстати, ни у кого нет решения, как это окно-вопрос побороть программно? (разрешить отсылку)
дословно окно имеет заголовок "Microsoft Office Outlook", на нем текстовка "Внешняя программа пытается ... бла...бла...бла" и 3 кнопки "Разрешить", "Запретить", "Справка". По умолчанию выбрана "Запретить"
спасибо!

[Gvaridos]

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

или так:

Sub SendReport()
  pt = "\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\"
  fn = "m 3173-229 " & Format(Now, "DD.MM.YY") & ".xls"
  On Error Resume Next
  Application.DisplayAlerts = False
  Workbooks.Open pt & fn
  If Err.Number > 0 Then
    Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = fn & " - не найден, ошибка:" & Err.Number
  Else
    ActiveWorkbook.SendMail "igorgo@ukr.net", "тема"
    ActiveWorkbook.Close
  End If
  Application.DisplayAlerts = True
End Sub

есть тут одна проблема, даже если это выполнить в 16:00 (как - Сергей написал). У меня почтовик - OutLook, он выбрасывает окно "Разрешить отсылку???" и ничего не произойдет дальше, пока не указать что же делать дальше.

Кстати, ни у кого нет решения, как это окно-вопрос побороть программно? (разрешить отсылку)
дословно окно имеет заголовок "Microsoft Office Outlook", на нем текстовка "Внешняя программа пытается ... бла...бла...бла" и 3 кнопки "Разрешить", "Запретить", "Справка". По умолчанию выбрана "Запретить"
спасибо!

Sub SendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

With OutMail
.To = Range("A1").Value
.Subject = Range("A2").Value
.Body = Range("A3").Value
.Attachments.Add Range("A4").Value
'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой
.Send
End With

On Error GoTo 0
Set OutMail = Nothing

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub


Адрес, тема, текст сообщения и путь к вложенному файлу должны быть в ячейках A1:A4 текущего листа.

[IgorGO]

Sub SendReport()
  On Error Resume Next
  Application.DisplayAlerts = False
  subj = [a2]: adr = [a1]
  Workbooks.Open [a4] & Format(Now, "DD.MM.YY") & ".xls"
  If Err.Number > 0 Then
    Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = fn & " - не найден, ошибка:" & Err.Number
  Else
    ActiveWorkbook.SendMail adr, subj
    ActiveWorkbook.Close
  End If
  Application.DisplayAlerts = True
End Sub

SendMail - есть метод книги, который отсылает ее самою. дополнительная передача сообщения не предусмотрена, есть только адрес, тема, и можно запросить подтверждение о получении

[Gvaridos]

Sub Рассылка()
pt = "\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\"
fn = "m 3173-229 " & Format(Now, "DD-1.MM.YY") & ".xls"
On Error Resume Next
Application.DisplayAlerts = False
Workbooks.Open pt & fn
If Err.Number > 0 Then
Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = fn & " - не найден, ошибка:" & Err.Number
Else
Application.Run "Отправка"
End If
Application.DisplayAlerts = True
End Sub

Sub Отправка()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

With OutMail
.To = "123@yandex.ru"
.Subject = "Отчёт о совершенных сделках"
.Body = "Добрый день Василий Александрович! Предоставляем вам, отчет брокера по операциям за предыдущий торговый день. С уважением, клиентский отдел УФО ОАО НТБ. Тел. 8(8482)952816"
.Attachments.Add ("\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\m 3173-229 ДАТА-1.xls")
'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой
.Send
End With

On Error GoTo 0
Set OutMail = Nothing

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub


Как сделать так, чтобы в когда описываешь путь приложения письма он вставлял "текущую дату - 1 день"?
Иначе не вставит файл в письмо

[doober]

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

Как сделать так, чтобы в когда описываешь путь приложения письма он вставлял "текущую дату - 1 день"?
Иначе не вставит файл в письмо

Format(Now - 1, "DD.MM.YY")

[Gvaridos]

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

Format(Now - 1, "DD.MM.YY")

Когда описываешь приложение письма нужно прописать путь к файлу:
.Attachments.Add ("\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\m 3173-229 ДАТА-1.xls")
А так как макрос запускается неоднократно, путь кажды раз меняется (а именно дата в имени файла).
Имя каждый раз такое: "m 3173-229 (Текущая дата - 1 день).xls"
Как вставить это в путь для приложения?

[IgorGO]

"цей дощ на довго" - слов из песни не выкинешь
.Attachments.Add ("\\Depo\RsBank51\Reports\Отчёты бэк-офиса\3173-229\m 3173-229 " & Format(Now - 1, "DD.MM.YY") & ".xls")
"верным путем идете, товарищ" (В.И.Ленин)

Имя каждый раз такое: "m 3173-229 (Текущая дата - 1 день).xls"

это уже давно все поняли кроме одного человека в этой переписке