CODEWITHSUNDEEP
vbaoutlook
Willy Chen
Willy Chen

Reputation: 23

Send all files in folder as separate attachments

I am trying to attach all files in a folder in separate emails using a modified version of this code from 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 = "[email protected]"
  .HTMLBody = "Test"
  .Send
End With
End Function

The issue comes with trying to put the file name into the email subject.

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

If I remove localfName from the subject, to send a generic subject for all emails, the code works fine.

When I put either fName or localfName (my attempt to debug the issue), the first email sends, but on the second iteration, the DIR function returns a file name from a different folder, and the code breaks because the file it's trying to attach can't be found.

Upvotes: 2

Views: 1687

Answers (1)

IAmNerd2000
IAmNerd2000

Reputation: 771

I would use a FileSystem object and then loop through all files in the directory like the following:

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 = "[email protected]"
      .HTMLBody = "Test"
      .Send
    End With
End Function

Upvotes: 1

Related Questions