Отправить все файлы в папке как отдельные вложения

Question

Я пытаюсь прикрепить все файлы в папке к отдельным сообщениям электронной почты, используя модифицированную версию этого кода из https://www.slipstick.com/developer/macro-send-files-email/.

Dim fldName As String

Sub SendFilesbyEmail()
' From http://slipstick.me/njpnx
Dim sFName As String

i = 0
fldName = "C:\Users\Test"
sFName = Dir(fldName)
Do While Len(sFName) > 0
'filter for only *.txt
  If Right(sFName, 4) = ".txt" Then
      Call SendasAttachment(sFName)
      i = i + 1
  End If
  sFName = Dir
Loop
MsgBox i & " files were sent"
End Sub

Function SendasAttachment(fName As String)

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments

Dim localfName As String
Dim localfldName As String

Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0) ' email
Set olAtt = olMsg.Attachments

' attach file
olAtt.Add (fldName & fName)
localfName = fName

   ' send message
With olMsg
  .Subject = "PDF Import: " & Left(localfName, Len(localfName) - 4)
  .To = "test@test.com"
  .HTMLBody = "Test"
  .Send
End With
End Function

Проблема связана с попыткой ввести имя файла в тему электронного письма..

.Subject = "PDF Import: " & Left(localfName, Len(localfName) - 4)

Если я удаляю localfName из темы, чтобы отправить общую тему для всех писем, код работает нормально.

Когда я ставлю либо fName, либо localfName (моя попытка отладкипроблема), первое электронное письмо отправляется, но на второй итерации функция DIR возвращает имя файла из другой папки, и код прерывается, поскольку не удается найти файл, который он пытается прикрепить.

Answer 1

Я бы использовал объект FileSystem и затем перебрал бы все файлы в каталоге следующим образом:

Sub SendFilesbyEmail()
    Dim objFSO as object
    Dim objFldr as Object
    Dim objFile  as Object

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = objFSO.GetFolder("C:\Users\Test")

    For Each objFile In objFldr.Files 
        strFullPath = objFldr.Path  & "\" & objFile.Name

        If LCase(Trim(objFSO.GetExtensionName(strFullPath))) = "txt" Then
            SendasAttachment(strFullPath)
        End If
    Next


    set objFldr = nothing
    set objFSO = nothing
End Sub


Function SendasAttachment(fullPath As String)

    Dim olApp As Outlook.Application
    Dim olMsg As Outlook.MailItem
    Dim olAtt As Outlook.Attachments

    Dim localfName As String
    Dim localfldName As String

    Set olApp = Outlook.Application
    Set olMsg = olApp.CreateItem(0) ' email
    Set olAtt = olMsg.Attachments

    ' attach file
    olAtt.Add (fullPath)
    localfName = fName

      '  send message
    With olMsg
      .Subject = "PDF Import: " & Left(fullPath, Len(fullPath) - 4)
      .To = "test@test.com"
      .HTMLBody = "Test"
      .Send
    End With
End Function