VBA to send emails attachment base on path (folder)

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,102
Office Version
2007
Platform
Windows


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
 

harky

Active Member
Joined
Apr 8, 2010
Messages
313
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:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,102
Office Version
2007
Platform
Windows
ahhhh It works now! Thanks..

it work wonder with the status now.. thanks!

Really appreciate the help here (y)
I'm glad to help you. Thanks for the feedback.
 

harky

Active Member
Joined
Apr 8, 2010
Messages
313
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.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,102
Office Version
2007
Platform
Windows
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.
 

mim92

New Member
Joined
Sep 23, 2018
Messages
3
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]
 

harky

Active Member
Joined
Apr 8, 2010
Messages
313
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:

Watch MrExcel Video

Forum statistics

Threads
1,101,949
Messages
5,483,842
Members
407,415
Latest member
Anton1999

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top