VBA to send emails attachment base on path (folder)

harky

Active Member
Joined
Apr 8, 2010
Messages
405
Office Version
  1. 2021
  2. 2019
Platform
  1. Windows
ABCDEF
S/NTo:ccSubjectBodyPath of Attachment folder
1abc@email1.comabc@email1.comtest email 1Hello EmailC:\Users\ABC\Desktop\SavedFolder\Folder1

<tbody>
</tbody>

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:
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


What do you mean?
 
Last edited:
Upvote 0

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
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


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 (y)

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
 
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


I'm glad to help you. Thanks for the feedback.
 
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

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


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!
 
Last edited:
Upvote 0
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
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

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

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