из Excel в OutLook (не всё так просто...)

[Koddo]

Добрый день.

Задача, на первый взгляд тревиальная, но...

Определённым адресатам нужно отправить определённые (уникальные) файлы:
N_2_*.xls - Петров@почта.ru,
N_3_*.xls - Сидоров@почта.ru
NS_*.xls - Иванов@почта.ru и т.п.
Файлы находятся всегда в одной и той же папке. Но, часть имени (дата) файла меняется: "N_2_290309.xls"
Тема письма: название файла (если можно, то без разширения)
Текст письма: произвольный (например "Добрый день.")

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

Просто отправка адресатам определённых файлов из папки получилась (макрос прилагается).

Затык в следующем:
1. Как макрос будет искать файл, если часть его имени изменится (в имени файла присутствует дата).
2. Если файла для этого адресата в папке нет, то макрос не должен отправлять пустое письмо без вложения.

Первое, в принципе, но не желательно, можно реализовать, убрав изменяемую часть файла (но очень не желательно).

Заранее спасибо.

(добавлено модератором - может, кому пригодится)

Посмотрите самый простой способ, как организовать отправку почты (рассылку писем)
(с использованием программы заполнения документов по шаблонам, с последующей отправке по почте)

В программе есть возможность формировать письма по шаблону (с подстановкой данных из таблицы Excel),
прикреплять сформированные документы и файлы из выбранной папки, и много других возможностей.

[mchip]

Вот этот функция :
Function FileYesNo (fname) As boolean
Dim fileSys As Object
Set fileSys = CreateObject("Scripting.FileSystemO bject")
FileYesNo = fileSys.FileExists(fname)
End Function
возвращает True или False если файл существует

fname = "D:\temp\N_2_290309.xls"

используй ее. Правило именования файла известно? Тогда можно собрать имя файла, путь и передать этой функции.

[mchip]

Хотя вот еще один вариант.

Sub test()
File1 = ThisWorkbook.Path & "\" & "N_2*.xls"
File1 = Dir(File1)
If File1 <> "" Then Debug.Print File1
End Sub

Он подходит больше.

[Koddo]

Простите за дилетанство, но вот второй вариат если использовать, куда его помещать в коде макроса, что бы он работал?

[mchip]

В прикрепленном файле макрос проверяет наличие файлов по заданной маске в своей директории.
Т.е. если файл "Книга 3.xlsm" сохранен в папке C:\TEMP\ он проверит все файлы в этой директории по маске заданной на странице "Лист2". Если файл удовлетворяет маске он прикрепляется, иначе нет.

[Koddo]

Добрый день.
Сперва хочу выразить благодарность за помощь и то что откликнулись.

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

Если нужного файла в папке нет (допустим, там вообще нет никаких файлов), то макром не должен создавать (и отправлять как результат) пустых писем без вложений. Т.е. , если папка пустая, то ни одного письма создано быть не должно, как бы макрос отработает "в пустую".

Я признателен за помощь, но и исходный макрос (без Вашего дополнения) делал абсолютно тоже самое - есть файл, он создаёт письмо и прикрепляет его, нет файла - он создаёт пустое письмо. А хотелось бы что бы он его не создавал вовсе. - возможно ли такое реализовать (к сожалению сам несколько далёк от VBA).

Опять обращаюсь к Вам за помощью.

[mchip]

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

[honeybeer]

Sub Test()
Dim msrFso As New FileSystemObject
Dim msrFolder As Folder
Dim msrFile As File
    FileTemplates = Array("N_2_", "N_3_", "NS_")                            'вот так делать не надо, я это сделал только из тестовых целей
    If Not msrFso.FolderExists("C:\TestFolder\") Then Exit Sub
    Set msrFolder = msrFso.GetFolder("C:\TestFolder\")
    If msrFolder.Files.Count = 0 Then Exit Sub
    For Each msrFile In msrFolder.Files
        For Each Item In FileTemplates
            If msrFile.ShortName Like (Item & "*") Then SendMail FileSpec:=msrFile.Path, Addresses:=GetAssociatedAddr(CStr(Item))
        Next Item
    Next msrFile
End Sub

Public Function GetAssociatedAddr(Key As String) As Collection
'На самом деле я не знаю где у вас хранятся адреса электронной почты и связи
    Set GetAssociatedAddr = Nothing
End Function

Public Sub SendMail(FileSpec As String, Addresses As Collection)
Dim msrFso As New FileSystemObject
Dim olApp As New Outlook.Application
Dim olMail As Outlook.MailItem
On Error GoTo Catch
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' формирование письма и его отправка произойдет только при соблюдении трех условий:
'1) файл FileSpec существует
'2) Addresses не пустая ссылка
'3) в Addresses есть минимум один элемент(адрес)
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    If Not msrFso.FileExists(FileSpec) Or Addresses Is Nothing Or Addresses.Count = 0 Then GoTo Catch
    Set olMail = olApp.CreateItem(olMailItem)
    olMail.Subject = msrFso.GetFileName(FileSpec)
    olMail.Body = "Не дождетесь."
    For Each Address In Addresses
        olMail.Recipients.Add Name:=Address
    Next Address
    olMail.Attachments.Add Source:=FileSpec
    olMail.Send
Catch:
    If Not olApp Is Nothing Then olApp.Quit
    Set olApp = Nothing
    Set fso = Nothing
End Sub

попробуйте разобраться в этом.

[Мартовский]

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

Добрый день.
Задача, на первый взгляд тревиальная, но...
Заранее спасибо.

Подскажите, решили ли?
Есть похожая задача:
Есть таблица Эксел. в ней мыло и номер договора
Есть набор файлов, в именах которых есть номер договора.
Нужно, чтобы прога посылала адресату файлы, соответствующие номеру договора.(на каждый адрес их может быть до 4х)

Подойдет ли ваша прога?