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

DanteAmor said:
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.
Click to expand...
 
Upvote 0

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Hi,
After doing more testing.. I tot if possible to enhance more? :eeek:

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


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

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? :/
Click to expand...


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)

DanteAmor said:
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
Click to expand...
 
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.

DanteAmor said:
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
Click to expand...

 
Last edited:
Upvote 0
harky said:
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.
Click to expand...

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

DanteAmor said:
I can not control all possible error messages that may exist, so I commented "just some cases".
Click to expand...
 
Last edited:
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
282
cwstudio2020
C
J
  • Question Question
VBA to send multiple emails with multiple attachments
Replies
5
Views
607
6StringJazzer
6StringJazzer
B
  • Solved
VBA to email recipient if column cells contain value
Replies
6
Views
475
bh24524
B
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
519
Domenic
D
I
  • Question Question
VBA Module to save & Send Active Sheet to List of recipients
Replies
1
Views
325
severynm
severynm

Forum statistics

Threads
1,223,228
Messages
6,170,875
Members
452,363
Latest member
merico17

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