Individual Outlook mails with attachments (select from folder)

[sanjay.k]

I have some data in excel where the Gen no (Employee No) and other information are given.
I have one folder on the Desktop name as Full&Final in path - "C:\Users\Sanjay Kumar\Desktop\F&F".
In the Full&Final folder i have sub folders based on Gen Nos.
Example in the Full&Final folder I have 2 different sub folders name as 200298 and 200267.
For attachments - In the sub folders there are PDFs with the Gen no_ Payslip and Gen no_ IT and Gen no_Name.
For Example in the sub folder 200298 there are 3 pdfs, 200298_Payslip 200298_IT Payslip 200298_Sanjay
I want to add only attachments with 200298_Payslip 200298_IT.
E-mail address and other information are in excel workbook.

I want to send mail through outlook to all individual though e-mail mention in column "AN"

for More clarification i have attached screen shots of final version of outlook mail which need to be sent with all details.

Appreciate if anyone can help help me solve this big problem.

Thanks

[vba_php]

so you want to loop through the subdirs, pick out the right PDFs, and send them as attachments in individual emails?

[sanjay.k]

Dear vba_php,
Yes . You are correct.

[maniacb]

Try

Option Explicit


Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Application.ScreenUpdating = False
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row 'For troubleshooting
    
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
        If IsEmpty(Cells(i, "AP").Value) Then 'Check for date
        Path = "C:\Users\Sanjay Kumar\Desktop\F&F\" & Sheet1.Cells(i, "C") & "\"
        With OutMail
            .To = Sheet1.Cells(i, "AN").Value
            .CC = ""
            .Subject = "Full & Final Settlement || " & Sheet1.Cells(i, "B") & " - " & Sheet1.Cells(i, "C")
            .HTMLBody = "Dear " & Cells(i, "D") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_Payslip.pdf"
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_IT.pdf"
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Set OutMail = Nothing
        Set OutApp = Nothing
        Sheet1.Cells(i, "AP").Value = Date 'Enter date in Column AP
        End If
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

[sanjay.k]

Dear Maniacb,

only one mail is able to send and gives and not able to send mails from second line. Error highlighted in below line.
.To = Sheet1.Cells(i, "AN").Value

Error discreption
Run time error '91:
Object Variable or with block variable not set.


Also there is no need to fill the dates for AP Column. Nothing has to be done in AP column.

[maniacb]

alright, try it now

Option Explicit


Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row 'For troubleshooting
    
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        'If IsEmpty(Cells(i, "AP").Value) Then 'Check for date
        Path = "C:\Users\Sanjay Kumar\Desktop\F&F\" & Sheet1.Cells(i, "C") & "\"
        With OutMail
            .To = Sheet1.Cells(i, "AN").Value
            .CC = ""
            .Subject = "Full & Final Settlement || " & Sheet1.Cells(i, "B") & " - " & Sheet1.Cells(i, "C")
            .HTMLBody = "Dear " & Cells(i, "D") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_Payslip.pdf"
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_IT.pdf"
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Set OutMail = Nothing
        Set OutApp = Nothing
        'Sheet1.Cells(i, "AP").Value = Date 'Enter date in Column AP
        'End If
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

[sanjay.k]

Dear maniacb,
Now it is working.
but when the file is missing then it is showing an error and not moved to next line.
Can it be possible that if mail are sent then in AQ column it comes as "mail successfully sent". and moved to next line
if not able to sent then "file name - missing mail not sent" and moved to next line.

[maniacb]

Give this code a whirl:

Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        'If IsEmpty(Cells(i, "AP").Value) Then 'Check for date
        Path = "C:\Users\Sanjay Kumar\Desktop\F&F\" & Sheet1.Cells(i, "C") & "\"
        With OutMail
            .To = Sheet1.Cells(i, "AN").Value
            .CC = ""
            .Subject = "Full & Final Settlement || " & Sheet1.Cells(i, "B") & " - " & Sheet1.Cells(i, "C")
            .HTMLBody = "Dear " & Cells(i, "D") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_Payslip.pdf"
            If Err.Number <> 0 And Err.Number = -2147024893 Then
                'MsgBox "Missing Path at row # " & i
                Sheet1.Cells(i, "AQ").Value = "File has NOT been sent"
                On Error GoTo -1
                GoTo skip
            End If
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_IT.pdf"
            If Err.Number <> 0 And Err.Number = -2147024893 Then
                'MsgBox "Missing Path at row # " & i
                Sheet1.Cells(i, "AQ").Value = "File has NOT been sent"
                On Error GoTo -1
                GoTo skip
            End If
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Sheet1.Cells(i, "AQ").Value = "File has been sent succesfully"
skip:
        Set OutMail = Nothing
        Set OutApp = Nothing
        'End If
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

[sanjay.k]

Dear maniacb,
It is always showing in AQ "File has NOT been sent" and no mails are able to sent (even when the files are correct in the folder)

[maniacb]

Try now. I was trapping the wrong error and had to recreate your environment to find the right error code.

Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        'If IsEmpty(Cells(i, "AP").Value) Then 'Check for date
        Path = "C:\Users\Sanjay Kumar\Desktop\F&F\" & Sheet1.Cells(i, "C") & "\"
        With OutMail
            .To = Sheet1.Cells(i, "AN").Value
            .CC = ""
            .Subject = "Full & Final Settlement || " & Sheet1.Cells(i, "B") & " - " & Sheet1.Cells(i, "C")
            .HTMLBody = "Dear " & Cells(i, "D") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_Payslip.pdf"
            If Err.Number <> 0 And Err.Number = -2147024894 Then
                'MsgBox "Missing Payslip File at row # " & i
                Sheet1.Cells(i, "AQ").Value = "File has NOT been sent"
                On Error GoTo -1
                GoTo skip
            End If
            .Attachments.Add Path & Sheet1.Cells(i, "C") & "_IT.pdf"
            If Err.Number <> 0 And Err.Number = -2147024894 Then
                'MsgBox "Missing IT File at row # " & i
                Sheet1.Cells(i, "AQ").Value = "File has NOT been sent"
                On Error GoTo -1
                GoTo skip
            End If
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Sheet1.Cells(i, "AQ").Value = "File has been sent successfully"
skip:
        Set OutMail = Nothing
        Set OutApp = Nothing
        'End If
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub

End Sub

[sanjay.k]

Dear Maniacb,
you are really very helpful and awesome.
The code is working fine now .

[maniacb]

If that takes care of your original question, please select*Thread Tools*from the menu link above and mark this thread as SOLVED.

Also, as a relatively new member of the forum, you may not be aware that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post in which the help was given. By doing so you can add to the reputation(s) of those who helped.