VBA to send emails attachment base on path (folder)

harky

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

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

harky

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

DanteAmor

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

harky

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

harky

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

DanteAmor

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

harky

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

Watch MrExcel Video

Forum statistics

Threads
1,101,761
Messages
5,482,728
Members
407,360
Latest member
JTGF

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