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:
yes this one..! thank u so much!!! :):):)!!

Try this

In H put the folder and the pattern
Examples:

C:\Users\ABC\Desktop\SavedFolder\Email1\test.JPG
C:\Users\ABC\Desktop\SavedFolder\Email1\*.pdf
C:\Users\ABC\Desktop\SavedFolder\Email1\*



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


    '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
        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 wPattern = "" Then wPattern = "*.*"
            'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
            If Dir(wPath, vbDirectory) <> "" Then
                wFile = Dir(wPath & wPattern)
                On Error Resume Next
                Do While wFile <> ""
                    'If Dir(wPath & wFile) <> "" Then
                        .Attachments.Add wPath & wFile
                    'End If
                    wFile = Dir()
                Loop
                On Error GoTo 0
            End If
            '.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

Now, you already have 2 versions, in a column and in 2 columns.
 
Upvote 0

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Hi,
After doing more testing.. I tot if possible to enhance more? :eek:

Add a Status Update at Column I for .sent mode.

Function like MACRO can check the max attached that serve allow.

And Status able to put remarks:
IF email; found exceed server attached size, it will ABORT action. Then status will update with remark: exceed server size at Column I and process the next row email.
IF email; found wrong file URL, it will ABORT action. Than status will update with remark: wrong file path at Column I and process the next row email.
IF email; found wrong folder URL, it will ABORT action. Than status will update with remark: wrong folder path at Column I and process the next row email.
IF email no error found; it will send email and update status with remark: email send! at Column I and process the next email.

Code:
Remark at Col I
Value = "Attach exceed server size" 'attached files exceed server size <-- can put colour in red?
Value = "wrong file path " 'Path file wrong <-- can put colour in red?
Value = "wrong folder path " 'Path folder wrong <-- can put colour in red?
"email send!" 'successful send email

wonder, if tht possible? :/


I'm glad to help you. Thanks for the feedback.
 
Last edited:
Upvote 0
Hi,
After doing more testing.. I tot if possible to enhance more? :eek:

Add a Status Update at Column I for .sent mode.

Function like MACRO can check the max attached that serve allow.

And Status able to put remarks:
IF email; found exceed server attached size, it will ABORT action. Then status will update with remark: exceed server size at Column I and process the next row email.
IF email; found wrong file URL, it will ABORT action. Than status will update with remark: wrong file path at Column I and process the next row email.
IF email; found wrong folder URL, it will ABORT action. Than status will update with remark: wrong folder path at Column I and process the next row email.
IF email no error found; it will send email and update status with remark: email send! at Column I and process the next email.

Code:
Remark at Col I
Value = "Attach exceed server size" 'attached files exceed server size <-- can put colour in red?
Value = "wrong file path " 'Path file wrong <-- can put colour in red?
Value = "wrong folder path " 'Path folder wrong <-- can put colour in red?
"email send!" 'successful send email

wonder, if tht possible? :/


just some cases, try this
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 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
            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
i had an error say
outlook does not recognize one or more names.
debug = .sent

EDIT: SOrr is my mistake, at the email. (Wrong address)

just some cases, try this
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 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
            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, i tested..

The action will ABORT if
exceed server attached size;
wrong file;
Wrong Folder;

tot need to put FileExists check if a file exists?

I try to put a folder tht has 133MB but msg come out is No file Attach?
If never put URL, it also No file Attach? If put never link should state email send

suppose to be exceed server attached size

I mean the msg is abit confuse.

just some cases, try this
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 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
            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, i tested..

The action will ABORT if
exceed server attached size;
wrong file;
Wrong Folder;

tot need to put FileExists check if a file exists?

I try to put a folder tht has 133MB but msg come out is No file Attach?
If never put URL, it also No file Attach? If put never link should state email send

suppose to be exceed server attached size

I mean the msg is abit confuse.

I can not control all possible error messages that may exist, so I commented "just some cases".
 
Upvote 0
ehh, than nvm because i try other.. there is an error where it show exceed server attached size

But than how come
If never put URL, it also No file Attach?
i tot, it suppose to email send/?


I can not control all possible error messages that may exist, so I commented "just some cases".
 
Last edited:
Upvote 0
The code is ok

But, i cant send out email without putting any URL
can tht be fix?

I can not control all possible error messages that may exist, so I commented "just some cases".
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,267
Members
448,558
Latest member
aivin

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