Attach any file in outlook through VBA and delete

[earthworm]

I have found the below macro from net and made some changes .
This macro is adding specific file only . I need to add any type of file extension in outlook as an attachment from a specific folder path . Please help

please note that on later stage i will make the folder variable to pick any file from variable folder and once the email is sent, The files in that folder deletes . So that on next day i dont have to clear my folders up to run

Sub Email_From_Excel_More_Options()

' Email

Dim emailApplication As Object
Dim emailItem As Object

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

If Range("B1").Value > 0 Then

' To add more receipt use structure emailItem.to = "email1@test.com; email2@test.com; email3@test.com"
' emailItem.to = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value

emailItem.To = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value

emailItem.CC = "email1@test.com"

' emailItem.BCC = "email3@test.com"

emailItem.Subject = "Subject line for the email."

emailItem.Body = "The message for the email."

' Attach any file from your computer.

emailItem.Attachments.Add ("C:\Users\iiiii\OneDrive\Desktop\Test\1.txt")

' Send the Email
' emailItem.Send

' Display the Email so the user can change it as desired before sending it.
' Use this OR .Send, but not both together.
emailItem.Display

Set emailItem = Nothing
Set emailApplication = Nothing

Else
End If

 

[daverunt]

Hi

try the following using file picker dialog. I left the filtering parts in as you can filter by extension if required.
I would be inclined to do the file kill outside of the attaching in case there's a problem and you end up with zero files, no mail

[Code]
Path = "C:\junk\"  ' - add your path

Set fd = Application.FileDialog(msoFileDialogFilePicker)

fd.Title = "Select the Files to Attach"
fd.AllowMultiSelect = True
fd.InitialFileName = Path
i = fd.Show
fd.Filters.Clear
fd.Filters.Add "All files", "*.*" ' can filter extn as required
If i <> -1 Then
             MsgBox "You cancelled the file selection"

Else

'Put the selected files into an array

ReDim arrFiles(1 To fd.SelectedItems.Count)
For idx = 1 To fd.SelectedItems.Count
arrFiles(idx) = fd.SelectedItems(idx)
Next

End If

'Use to do the file attaching and deletion - put in the email code section instead of your attachments line

For i = 1 To UBound(arrFiles)
emailItem..Attachments.Add (arrFiles(i))
Kill (arrFiles(i))
             Next I



'Or separate the kill process to later in the code
            For j= 1 To UBound(arrFiles)
                    Kill (arrFiles(j))
             Next I

 

[earthworm]

Hi

try the following using file picker dialog. I left the filtering parts in as you can filter by extension if required.
I would be inclined to do the file kill outside of the attaching in case there's a problem and you end up with zero files, no mail

[Code]
Path = "C:\junk\"  ' - add your path

Set fd = Application.FileDialog(msoFileDialogFilePicker)

fd.Title = "Select the Files to Attach"
fd.AllowMultiSelect = True
fd.InitialFileName = Path
i = fd.Show
fd.Filters.Clear
fd.Filters.Add "All files", "*.*" ' can filter extn as required
If i <> -1 Then
             MsgBox "You cancelled the file selection"

Else

'Put the selected files into an array

ReDim arrFiles(1 To fd.SelectedItems.Count)
For idx = 1 To fd.SelectedItems.Count
arrFiles(idx) = fd.SelectedItems(idx)
Next

End If

'Use to do the file attaching and deletion - put in the email code section instead of your attachments line

For i = 1 To UBound(arrFiles)
emailItem..Attachments.Add (arrFiles(i))
Kill (arrFiles(i))
             Next I



'Or separate the kill process to later in the code
            For j= 1 To UBound(arrFiles)
                    Kill (arrFiles(j))
             Next I

Thanks for the code . I havent tried it . I dont want the dialouge box to locate the folder . I will make a variable location and map it so that that files will be selected automatically from variable folders .

 

[daverunt]

Hi,

I'm not sure I follow but maybe this is nearer the attachment code you want if you change the path to a variable.

Attach multiple files or entire directory to email

I'm trying to send an Outlook email with multiple attachments via Excel VBA. The code works if I specify the path to one attachment/file. I can also add multiple attachments if I know exactly what...

stackoverflow.com

 

[earthworm]

Can you please share the complete code as i dont know where to input

 

[daverunt]

To add all files in a folder?

Sub Email_From_Excel_More_Options()

Dim emailApplication As Object
Dim emailItem As Object



'~~> Change path here
    StrPath = "C:\junk\"


Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

If Range("B1").Value > 0 Then

' To add more receipt use structure emailItem.to = "email1@test.com; email2@test.com; email3@test.com"
' emailItem.to = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value

emailItem.To = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value

emailItem.CC = "email1@test.com"

' emailItem.BCC = "email3@test.com"

emailItem.Subject = "Subject line for the email."

emailItem.Body = "The message for the email."

  '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")

        Do While Len(StrFile) > 0
emailItem.Attachments.Add StrPath & StrFile
'Kill StrPath & StrFile ----------------kills file once attached
StrFile = Dir
        Loop


' Attach any file from your computer.
' emailItem.Attachments.Add ("C:\Users\iiiii\OneDrive\Desktop\Test\1.txt")

' Send the Email
' emailItem.Send

' Display the Email so the user can change it as desired before sending it.
' Use this OR .Send, but not both together.
emailItem.Display

Set emailItem = Nothing
Set emailApplication = Nothing

Else
End If

End Sub

 

[daverunt]

Tidied up a bit and moved file delete to after mail sent/displayed

Sub Email_From_Excel_More_Options()

Dim emailApplication As Object
Dim emailItem As Object

'Change attachment directory path here
    StrPath = "C:\junk\"

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

If Range("B1").Value > 0 Then

With emailItem
'To add more receipt use structure emailItem.to = "email1@test.com; email2@test.com; email3@test.com"
   .To = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value
   .CC = "email1@test.com"
' .BCC = "email3@test.com"
   .Subject = "Subject line for the email."
   .Body = "The message for the email."

'Multiple file attach
  StrFile = Dir(StrPath & "*.*")
  Do While Len(StrFile) > 0
  .Attachments.Add StrPath & StrFile
  'Kill StrPath & StrFile
  StrFile = Dir
  Loop
' Display the Email so the user can change it as desired before sending it.
' Use this OR .Send, but not both together.
.Display
'.Send
End With

'Delete all files in attachment directory
        StrFile = Dir(StrPath & "*.*")
        Do While Len(StrFile) > 0
   '     Kill StrPath & StrFile --------------commented out so it doesn't delete your files
        StrFile = Dir
        Loop

Set emailItem = Nothing
Set emailApplication = Nothing
Else
End If

End Sub

 

[earthworm]

I

Tidied up a bit and moved file delete to after mail sent/displayed

Sub Email_From_Excel_More_Options()

Dim emailApplication As Object
Dim emailItem As Object

'Change attachment directory path here
    StrPath = "C:\junk\"

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

If Range("B1").Value > 0 Then

With emailItem
'To add more receipt use structure emailItem.to = "email1@test.com; email2@test.com; email3@test.com"
   .To = Range("C1").Value & "; " & Range("D1").Value & "; " & Range("E1").Value
   .CC = "email1@test.com"
' .BCC = "email3@test.com"
   .Subject = "Subject line for the email."
   .Body = "The message for the email."

'Multiple file attach
  StrFile = Dir(StrPath & "*.*")
  Do While Len(StrFile) > 0
  .Attachments.Add StrPath & StrFile
  'Kill StrPath & StrFile
  StrFile = Dir
  Loop
' Display the Email so the user can change it as desired before sending it.
' Use this OR .Send, but not both together.
.Display
'.Send
End With

'Delete all files in attachment directory
        StrFile = Dir(StrPath & "*.*")
        Do While Len(StrFile) > 0
   '     Kill StrPath & StrFile --------------commented out so it doesn't delete your files
        StrFile = Dir
        Loop

Set emailItem = Nothing
Set emailApplication = Nothing
Else[CODE=vba]
Sub Email_From_Excel_Attachments()

I tried this loop but still files inside a folder is not being attached in email . to make things more easier to understand below is the actual code

Dim emailApplication As Object
Dim emailItem As Object

Dim StrPath As String
StrPath = ("C:\Users\iiiii\OneDrive\Desktop\Test\")

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

emailItem.Body = "The message for the email."

Dim x As Integer
For x = 1 To 1

Sheets("DB").Select

Dim name As String
name = Range("H" & x + 1)

Dim StrFile As String

With emailItem
        .To = "test@test.org"
        .CC = "test@test.org"
        .Bcc = "test@test.org"
        .Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")

        Do While Len(StrFile) > 0
            .Attachments.Add StrPath & StrFile
            StrFile = Dir
        Loop
    

' Display email before send
emailItem.Display
End With

' Send the Email
' emailItem.Send

Set emailItem = Nothing
Set emailApplication = Nothing
Next x
End Sub
End If

Please note that in sheet DB Cell H2 there is name of company which is set as variable below is the actual patch for the file located in this folder
C:\Users\iiiii\OneDrive\Desktop\Test\Aftab Currency Exchange UK

The macro is not going inside the company folder to pick the file and attach . I tried every technique i can try but still i am lost. You can see the above code . please advice what am i doing wrong here

 

[daverunt]

Hi,

I don't see where you use a variable in the StrPath?

Anyway here's what I think you are trying to do.
I moved the DIM statements to the top so they are less visually distracting but that's my choice and may not be yours.

There are words that shouldn't be used as variables in code. I'm not sure if 'name' is one of those so I use Nme in case it is.
You need to get the value for Nme before you can use it in the StrPath hence the code is shuffled around a bit.

Sub Email_From_Excel_More_Options()
Dim emailApplication As Object
Dim emailItem As Object
Dim StrPath As String
Dim x As Integer
Dim Nme As String
Dim StrFile As String

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Sheets("DB").Select

For x = 1 To 1
Nme = Range("H" & x + 1)

StrPath = ("C:\Users\" & Nme & "\OneDrive\Desktop\Test\")

emailItem.Body = "The message for the email."

With emailItem
.To = "test@test.org"
.CC = "test@test.org"
.Bcc = "test@test.org"
.Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")

        Do While Len(StrFile) > 0
.Attachments.Add StrPath & StrFile
StrFile = Dir
Loop
   
' Display email before send
.Display
End With

' Send the Email
' .Send

Set emailItem = Nothing
Set emailApplication = Nothing
Next x

End Sub

 

[earthworm]

Hi,

I don't see where you use a variable in the StrPath?

Anyway here's what I think you are trying to do.
I moved the DIM statements to the top so they are less visually distracting but that's my choice and may not be yours.

There are words that shouldn't be used as variables in code. I'm not sure if 'name' is one of those so I use Nme in case it is.
You need to get the value for Nme before you can use it in the StrPath hence the code is shuffled around a bit.

Sub Email_From_Excel_More_Options()
Dim emailApplication As Object
Dim emailItem As Object
Dim StrPath As String
Dim x As Integer
Dim Nme As String
Dim StrFile As String

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Sheets("DB").Select

For x = 1 To 1
Nme = Range("H" & x + 1)

StrPath = ("C:\Users\" & Nme & "\OneDrive\Desktop\Test\")

emailItem.Body = "The message for the email."

With emailItem
.To = "test@test.org"
.CC = "test@test.org"
.Bcc = "test@test.org"
.Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")

        Do While Len(StrFile) > 0
.Attachments.Add StrPath & StrFile
StrFile = Dir
Loop
  
' Display email before send
.Display
End With

' Send the Email
' .Send

Set emailItem = Nothing
Set emailApplication = Nothing
Next x

End Sub

Nah . The macro is still not picking the file inside the subfolder here is the explanation of code

Sub Email_From_Excel_More_Options()
Dim emailApplication As Object
Dim emailItem As Object
Dim StrPath As String
Dim x As Integer         ' This mentioned to make the location of file and cell variable
Dim Nme As String
Dim StrFile As String

Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)

Sheets("DB").Select ' This sheet contains the list of company with their values

For x = 1 To 1   ' I am trying to test one case only to check if the macro is picking the file inside folder

Nme = Range("H" & x + 1) ' This cell contains the name of companies for which their folders with name mentioned on cell are created inside test folder

StrPath = ("C:\Users\" & Nme & "\OneDrive\Desktop\Test\")  ' The sub folder is located inside this main folder

emailItem.Body = "The message for the email."

With emailItem
.To = "test@test.org"
.CC = "test@test.org"
.Bcc = "test@test.org"
.Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*") ' To search for any file located in sub folder as searched from internet              

        Do While Len(StrFile) > 0
.Attachments.Add StrPath & StrFile
StrFile = Dir
Loop