VBA to send emails attachment base on path (folder)

H

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[TD="align: center"]F[/TD]
[/TR]
[TR]
[TD="align: center"]S/N[/TD]
[TD="align: center"]To:[/TD]
[TD="align: center"]cc[/TD]
[TD="align: center"]Subject[/TD]
[TD="align: center"]Body[/TD]
[TD="align: center"]Path of Attachment folder[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]abc@email1.com[/TD]
[TD]abc@email1.com[/TD]
[TD]test email 1[/TD]
[TD]Hello Email[/TD]
[TD]C:\Users\ABC\Desktop\SavedFolder\Folder1[/TD]
[/TR]
</tbody>[/TABLE]

I had a code below, possible to attach a code which will attach any file tht found in Path of Attachment folder?
If no folder or nth in the folder, it will be ignored.



Code: 
Sub SendEmail()


'START of confirmation message box'
    response = MsgBox("Start sending email?", vbYesNo)
    If response = vbNo Then
    MsgBox ("Macro Canceled!")
    Exit Sub
    End If
'END of confirmation message box'


Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim wks As Worksheet


lr = Cells(Rows.Count, "B").End(xlUp).Row


Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("send_email")


For i = 2 To lr
        With Mail_Object.CreateItem(o)
            .To = wks.Range("B" & i).Value
            .CC = wks.Range("C" & i).Value
            .Subject = wks.Range("D" & i).Value
            .Body = wks.Range("E" & i).Value
            .Send
            '.display 'disable display and enable send to send automatically
            Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
    End With
Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
 
Last edited:
Sort by date Sort by votes
IYO290U.jpg


Hi,
i refer to yellow box highlighted here.
if H is empty, email cannot be send out.

It suppose to send out if H is empty


DanteAmor said:
What do you mean?
Click to expand...
 
Last edited:
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
harky said:
IYO290U.jpg


Hi,
i refer to yellow box highlighted here.
if H is empty, email cannot be send out.

It suppose to send out if H is empty
Click to expand...


Try:

Code: 
Sub SendEmail()
    Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
    Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
    Dim num_err As Variant, sErr As Boolean


    'START of confirmation message box'
    response = MsgBox("Start sending email?", vbYesNo)
    If response = vbNo Then
        MsgBox ("Macro Canceled!")
        Exit Sub
    End If
    'END of confirmation message box'
    Set Mail_Object = CreateObject("Outlook.Application")
    Set wks = Worksheets("send_email")
    lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 2 To lr
        sErr = False
        With Mail_Object.CreateItem(o)
            .to = wks.Range("B" & i).Value
            .cc = wks.Range("C" & i).Value
            .Subject = wks.Range("D" & i).Value
            .Body = wks.Range("E" & i).Value & vbNewLine & _
                wks.Range("F" & i).Value & vbNewLine & _
                wks.Range("G" & i).Value
             
            pf = wks.Range("H" & i).Value
            d = InStrRev(pf, "\")
            wPath = Left(pf, d)
            wPattern = Mid(pf, d + 1)
            If wPath <> "" Then
                If wPattern = "" Then wPattern = "*.*"
                'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
                If Dir(wPath, vbDirectory) <> "" Then
                    wFile = Dir(wPath & wPattern)
                    On Error Resume Next
                    If wFile <> "" Then
                        Do While wFile <> ""
                            .Attachments.Add wPath & wFile
                            num_error = Err.Number
                            If num_error <> 0 Then
                                wks.Range("I" & i).Value = "No file Attach"
                                sErr = True
                            End If
                            wFile = Dir()
                        Loop
                    Else
                        wks.Range("I" & i).Value = "wrong file"
                        sErr = True
                    End If
                    On Error GoTo 0
                Else
                    wks.Range("I" & i).Value = "wrong file path"
                    sErr = True
                End If
            End If
            If sErr = False Then
                .Send
                '.display 'disable display and enable send to send automatically
                num_error = Err.Number
                If num_error <> 0 Then
                    wks.Range("I" & i).Value = Err.Description
                Else
                    wks.Range("I" & i).Value = "email send"
                End If
            End If
            'Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
        End With
    Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
    Set Mail_Object = Nothing
End Sub
 
Upvote 0
ahhhh It works now! Thanks..

it work wonder with the status now.. thanks!

Really appreciate the help here :beerchug:

DanteAmor said:
Try:

Code: 
Sub SendEmail()
    Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
    Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
    Dim num_err As Variant, sErr As Boolean


    'START of confirmation message box'
    response = MsgBox("Start sending email?", vbYesNo)
    If response = vbNo Then
        MsgBox ("Macro Canceled!")
        Exit Sub
    End If
    'END of confirmation message box'
    Set Mail_Object = CreateObject("Outlook.Application")
    Set wks = Worksheets("send_email")
    lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 2 To lr
        sErr = False
        With Mail_Object.CreateItem(o)
            .to = wks.Range("B" & i).Value
            .cc = wks.Range("C" & i).Value
            .Subject = wks.Range("D" & i).Value
            .Body = wks.Range("E" & i).Value & vbNewLine & _
                wks.Range("F" & i).Value & vbNewLine & _
                wks.Range("G" & i).Value
             
            pf = wks.Range("H" & i).Value
            d = InStrRev(pf, "\")
            wPath = Left(pf, d)
            wPattern = Mid(pf, d + 1)
            If wPath <> "" Then
                If wPattern = "" Then wPattern = "*.*"
                'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
                If Dir(wPath, vbDirectory) <> "" Then
                    wFile = Dir(wPath & wPattern)
                    On Error Resume Next
                    If wFile <> "" Then
                        Do While wFile <> ""
                            .Attachments.Add wPath & wFile
                            num_error = Err.Number
                            If num_error <> 0 Then
                                wks.Range("I" & i).Value = "No file Attach"
                                sErr = True
                            End If
                            wFile = Dir()
                        Loop
                    Else
                        wks.Range("I" & i).Value = "wrong file"
                        sErr = True
                    End If
                    On Error GoTo 0
                Else
                    wks.Range("I" & i).Value = "wrong file path"
                    sErr = True
                End If
            End If
            If sErr = False Then
                .Send
                '.display 'disable display and enable send to send automatically
                num_error = Err.Number
                If num_error <> 0 Then
                    wks.Range("I" & i).Value = Err.Description
                Else
                    wks.Range("I" & i).Value = "email send"
                End If
            End If
            'Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
        End With
    Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
    Set Mail_Object = Nothing
End Sub
Click to expand...
 
Last edited:
Upvote 0
Hi Thanks.

I been using this script.

Can i add one more function?

In outlook, there is a SAVE SENT ITEM TO XX folder
Can i save sent in my ARCHIVE Folder?

Main: 2019_ARCHIVE
Subfolder: SendFolder


DanteAmor said:
I'm glad to help you. Thanks for the feedback.
Click to expand...
 
Upvote 0
harky said:
Hi Thanks.

I been using this script.

Can i add one more function?

In outlook, there is a SAVE SENT ITEM TO XX folder
Can i save sent in my ARCHIVE Folder?

Main: 2019_ARCHIVE
Subfolder: SendFolder
Click to expand...

I don't know that function. I suggest you create a new thread, we hope someone helps you.
 
Upvote 0
Hi guys, new to vba so not sure if the above is actually the answer I'm looking for but it seems the closest to what I've been looking for.
I send emails out to the same people every month with the same subject and body each month sending 4 pdf reports in sub folders which are relevant to each individual month. This file path element will always be the same [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]\\corp.copart.com\share\UKFinance\Management Accounts\Monthly Management Accts 18_19 but its then the monthly sub folder which then includes another sub folder for each location and then final subfolder containing the reports which I need to select [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]\\corp.copart.com\share\UKFinance\Management Accounts\Monthly Management Accts 18_19\Period 12.19 July\Yard reports\401 Sandy. THESE FOLDERS ONLY CONTAIN THE 4 PDF REPORTS I SEND OUT SO IF I COULD JUST SELECT EVERYTHING IN THE FOLDER THAT WOULD BE GREAT. I don't need a dynamic excel list containing email addresses as these won't but if using an excel spreadsheet like above with file paths. email addresses etc is easier I'm happy to use one. Thanks!
[/FONT][/FONT]
 
Upvote 0
If u read, it does what u want..

attach 1 file or all file from the folder


mim92 said:
Hi guys, new to vba so not sure if the above is actually the answer I'm looking for but it seems the closest to what I've been looking for.
I send emails out to the same people every month with the same subject and body each month sending 4 pdf reports in sub folders which are relevant to each individual month. This file path element will always be the same \\corp.copart.com\share\UKFinance\Management Accounts\Monthly Management Accts 18_19 but its then the monthly sub folder which then includes another sub folder for each location and then final subfolder containing the reports which I need to select \\corp.copart.com\share\UKFinance\Management Accounts\Monthly Management Accts 18_19\Period 12.19 July\Yard reports\401 Sandy. THESE FOLDERS ONLY CONTAIN THE 4 PDF REPORTS I SEND OUT SO IF I COULD JUST SELECT EVERYTHING IN THE FOLDER THAT WOULD BE GREAT. I don't need a dynamic excel list containing email addresses as these won't but if using an excel spreadsheet like above with file paths. email addresses etc is easier I'm happy to use one. Thanks!
Click to expand...
 
Last edited:
Upvote 0
DanteAmor said:
Try:

Code: 
Sub SendEmail()
    Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
    Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
    Dim num_err As Variant, sErr As Boolean


    'START of confirmation message box'
    response = MsgBox("Start sending email?", vbYesNo)
    If response = vbNo Then
        MsgBox ("Macro Canceled!")
        Exit Sub
    End If
    'END of confirmation message box'
    Set Mail_Object = CreateObject("Outlook.Application")
    Set wks = Worksheets("send_email")
    lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 2 To lr
        sErr = False
        With Mail_Object.CreateItem(o)
            .to = wks.Range("B" & i).Value
            .cc = wks.Range("C" & i).Value
            .Subject = wks.Range("D" & i).Value
            .Body = wks.Range("E" & i).Value & vbNewLine & _
                wks.Range("F" & i).Value & vbNewLine & _
                wks.Range("G" & i).Value
           
            pf = wks.Range("H" & i).Value
            d = InStrRev(pf, "\")
            wPath = Left(pf, d)
            wPattern = Mid(pf, d + 1)
            If wPath <> "" Then
                If wPattern = "" Then wPattern = "*.*"
                'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
                If Dir(wPath, vbDirectory) <> "" Then
                    wFile = Dir(wPath & wPattern)
                    On Error Resume Next
                    If wFile <> "" Then
                        Do While wFile <> ""
                            .Attachments.Add wPath & wFile
                            num_error = Err.Number
                            If num_error <> 0 Then
                                wks.Range("I" & i).Value = "No file Attach"
                                sErr = True
                            End If
                            wFile = Dir()
                        Loop
                    Else
                        wks.Range("I" & i).Value = "wrong file"
                        sErr = True
                    End If
                    On Error GoTo 0
                Else
                    wks.Range("I" & i).Value = "wrong file path"
                    sErr = True
                End If
            End If
            If sErr = False Then
                .Send
                '.display 'disable display and enable send to send automatically
                num_error = Err.Number
                If num_error <> 0 Then
                    wks.Range("I" & i).Value = Err.Description
                Else
                    wks.Range("I" & i).Value = "email send"
                End If
            End If
            'Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
        End With
    Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
    Set Mail_Object = Nothing
End Sub
Click to expand...
Hi ,

I been using this.... it work great.
isit possible to have a pop-up for user to set the timer?
like user key in 0:00:08, the email pausing for 8s , before next email
instead of put inside the code
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
VBA: Automatically send emails in a loop with different attachments
Replies
3
Views
294
cwstudio2020
C
J
  • Question Question
VBA to send multiple emails with multiple attachments
Replies
5
Views
676
6StringJazzer
6StringJazzer
S
  • Question Question
VBA sending an email of two conditions are met
Replies
5
Views
139
mumps
mumps
B
  • Solved
VBA to email recipient if column cells contain value
Replies
6
Views
541
bh24524
B
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
619
Domenic
D

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,633
Latest member
DougMo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top