Прикрепите только один файл из места, где есть несколько файлов

Question

Каждый месяц я отправляю около двухсот трехсот отдельных электронных писем с одним файлом Excel в качестве вложения.

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

Ниже приведен код VBA, написанный до сих пор, но Outlook импортирует все файлы из этого расположения.

Sub Outlook_Project()

Dim origEmail As Object
Dim newEmail As MailItem
Dim MyPath As String

Set origEmail = CreateObject("Outlook.Application")
Set newEmail = CreateItemFromTemplate("C:\Users\new folder\Template.oft")
newEmail.Subject = "mySubject"

newEmail.Recipients.Add "test@test"
StrPath = "C:\Users\Desktop\Test\"

With newEmail
    strFile = Dir(StrPath & "*.*")
    Do While Len(strFile) > 0
        .Attachments.Add StrPath & strFile
        strFile = Dir
    Loop
End With

newEmail.Display
Set origEmail = Nothing
Set newEmail = Nothing

End Sub

Answer 1

Попробуйте этот код, пожалуйста:

Sub testOutlook()
 Dim origEmail As Object, newEmail As Object
 Dim StrPath As String, strFile As String, mailsList() As String
 Dim myFileName As String, El As Variant

 StrPath = "C:\Users\your_user\Desktop\Test\"
 mailsList = Split("test1@test.com,test2@test.com,test3@test.com", ",")
             'You can also collect the mail accounts name from a sheet list (on row or column).
 myFileName = "Test1.txt" ' You must find a way to create it according to some criteria

 Set origEmail = CreateObject("Outlook.Application")

 For Each El In mailsList
    Set newEmail = CreateItemFromTemplate("C:\Users\new folder\Template.oft")
    newEmail.Subject = "mySubject"
    newEmail.Recipients.Add El
    newEmail.Attachments.Add StrPath & myFileName
    newEmail.send
 Next

 Set origEmail = Nothing: Set newEmail = Nothing
End Sub

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

Answer 2

Основываясь на идее RicingFX, я попробовал другой подход, ниже вы можете найти рабочий код, это все, что мне нужно:

Sub Outlook_Project()

Dim StrFile As String, StrPath As String
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem


Set appOutLook = CreateObject("Outlook.Application")

StrPath = "C:\Users\User\Desktop\Test\"
StrFile = Dir("C:\Users\User\Desktop\Test\*.xlsx")


Do While Len(StrFile) > 0


Set MailOutLook = CreateItemFromTemplate("C:\Users\User\Desktop\Template.oft")

With MailOutLook
.BodyFormat = olFormatHTML
.SentOnBehalfOfName = "Test@Test.com"
.Subject = "MySubject"



.Attachments.Add StrPath + StrFile
.Display


End With
StrFile = Dir
Loop

End Sub

Спасибо, ребята, за вашу поддержку.

Answer 3

в своем коде вы создаете новое письмо и прикрепляете каждый файл в этом каталоге к этому письму. Если вы хотите сгенерировать почту для каждого файла, вам нужно перебрать файлы, а затем создать почту внутри l oop. Вам также следует подумать о сопоставлении между файлом и получателем, если их несколько.