Send mail from Excel

[Priyantha]

Dear All,

I am using two macros to send Emails using an attachment with Gmail.
separately using, 01 for setting a password (PDF Attachment) 02. for sending emails. they work correctly while used separately. but I tried to combine them as one macro & while running it is displaying runtime error ** -2147024894 The System can't find file Specified**

My combined Code: Attached

the first part of the code is used to set a password for PDF File & second part is used to send mail with attachments. my file path is correct. Finally I tried removing the below code,

Attach_01 = "C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips" & em.Cells(j, "B").Value & ".pdf"

then was run the code & ware send maile without attachment.

please help me to solve this issue.

Priyantha

[HansV]

It would have been better to edit the subject and remove RESOLVED...
(This was before the posts were moved)

[HansV]

The line

Code: Select all

    Kill ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" & em.Cells(j, 2).Value & "*N.pdf")

should be moved to just above the line

Code: Select all

Next j

so that it is inside the loop.
Does that solve the problem?

[HansV]

I have moved the above three posts to a new thread, since they have nothing to do with the thread they were posted in.

[Priyantha]

Dear Hans,

I moved to just above the line Below the code but same error.

Kill ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" & em.Cells(j, 2).Value & "*N.pdf")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''Status'''''''''

If em.Cells(j, 7).Value = "" Then
em.Cells(j, 9).Value = " No Sent"

ElseIf em.Cells(j, 7).Value = 0 Then
em.Cells(j, 9).Value = " No Sent"

ElseIf AttachExists = "" Then
em.Cells(j, 9).Value = " No Sent"

Else

em.Cells(j, 9).Value = "Sent"

End If

Kill ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" & em.Cells(j, 2).Value & "*N.pdf") ,,,, Now

Application.Wait (Now + TimeValue("0:00:01"))

Next j

With Application
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.DisplayStatusBar = False
End With

''Kill ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" & em.Cells(j, 2).Value & "*N.pdf") ----- Before

MsgBox "All email has been sent", vbInformation

NextID:

Exit_Err:
'Release object memory
Set NewMail = Nothing
Set mailConfig = Nothing
End

Err:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select

Resume Exit_Err

End Sub

[HansV]

1) Move the first instance of that line to just above

Next j

as I wrote in my first reply.

2) Delete the second instance of that line.

[Priyantha]

Dear Hans,

I Tried as you said. but the same error.

Modified code attached here with.

thanks
Priyantha

[HansV]

Does the error occur on the line highlighted in yellow in your screenshot? That is different than the line you reported earlier.
It would indicate that the file you're trying to attach does not exist.

[HansV]

Does this work?

Code: Select all

Sub SendEmailUsingGmail_Welser()
    Const newPath = "C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\"

    Dim NewMail As Object, mailConfig As Object, fields As Variant, msConfigURL As String, last_row As Long
    Dim j As Long, Attach_01 As String, AttachExists_01 As String
    Dim em As Worksheet
    Dim Attach As String
    Dim AttachExists As String
    Dim filename_01 As String
    Dim retval As String
    Dim FileOrigine As String, FileDestinazione As String
    Dim MyPwd As String, strParam As String

    On Error GoTo Err:

    With Application
        .Calculation = xlCalculationManual
        .DisplayAlerts = True
        .DisplayStatusBar = True
    End With

    Set em = ThisWorkbook.Sheets("Email")
    last_row = em.Range("B" & em.Rows.Count).End(xlUp).Row

    For j = 4 To last_row
        filename_01 = em.Cells(j, 2).Value
        Attach = newPath & filename_01 & "*N.pdf"
        AttachExists = Dir(Attach)
        If AttachExists = "" Then
            em.Cells(j, 9).Value = " No Attachment"
            GoTo NextID
        ElseIf em.Cells(j, 7).Value = "" Then
            em.Cells(j, 9).Value = " No Email Address"
            GoTo NextID
        ElseIf em.Cells(j, 7).Value = 0 Then
            em.Cells(j, 9).Value = " No Email Address"
            GoTo NextID
        End If

        ''''' Set Password to PDF Files '''''''
        FileOrigine = newPath & filename_01 & "N.pdf"

        MyPwd = em.Cells(j, "H").Value
        FileDestinazione = newPath & filename_01 & ".pdf"

        FileOrigine = """" & FileOrigine & """"
        FileDestinazione = """" & FileDestinazione & """"
        MyPwd = """" & MyPwd & """"

        strParam = FileOrigine _
                 & " Output " & FileDestinazione _
                 & " User_pw " & MyPwd _
                 & " Allow AllFeatures"

        retval = Shell("C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & strParam, 0) '<<=== Percorso da adattare N.B. lo spazio dopo pdftk.exe

        Attach_01 = newPath & filename_01 & ".pdf"
        AttachExists_01 = Dir(Attach_01)
        If AttachExists_01 = "" Then
            em.Cells(j, 9).Value = " Could Not Create Protected PDF"
            GoTo NextID
        End If

        Set NewMail = CreateObject("CDO.Message")
        Set mailConfig = CreateObject("CDO.Configuration")
        mailConfig.Load -1
        Set fields = mailConfig.fields
        'Set Email Properties
        With NewMail
            .From = "salary2.lvpp@gmail.com"
            .To = em.Cells(j, 7).Value
            .CC = ""
            .BCC = ""
            .Subject = "Salary Slip For the Month of   " & em.Range("D1").Value
            .TextBody = "Dear  " & em.Cells(j, 3).Value & "," & vbNewLine & vbNewLine & _
                "Please find your attached salary slip for the month of  " & _
                em.Range("D1").Value & "." & vbNewLine & vbNewLine & _
                "To open it, you are supposed to type your birth year and month without spaces as the password." & _
                vbNewLine & "(Ex: if your year of birth is 1985 and month is june, your password would be 198506)" & _
                vbNewLine & vbNewLine & "For any assistance, please contact 070-6702525 - Payroll Unit" & _
                vbNewLine & vbNewLine & "Best Regards," & vbNewLine & vbNewLine & "I.W. Karunarathna," & _
                vbNewLine & "Accountant (Payment & Payroll)," & vbNewLine & "Lakvijaya Power Station."
            .AddAttachment Attach_01
        End With

        msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

        With fields
            .Item(msConfigURL & "/smtpusessl") = True             'Enable SSL Authentication
            .Item(msConfigURL & "/smtpauthenticate") = 1          'SMTP authentication Enabled
            .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com" 'Set the SMTP server details
            .Item(msConfigURL & "/smtpserverport") = 465          'Set the SMTP port Details
            .Item(msConfigURL & "/sendusing") = 2                 'Send using default setting
            .Item(msConfigURL & "/sendusername") = "salary.lvpp@gmail.com" 'Your gmail address
            .Item(msConfigURL & "/sendpassword") = "zolb xrkc cwko ones" 'Your password or App Password
            .Update                                               'Update the configuration fields
        End With

        NewMail.Configuration = mailConfig
       NewMail.Send

        '''' Status Bar'''''''
        Application.StatusBar = "Progress:  " & "PF No. : " & filename_01 & "   " & _
        j - 3 & " of " & last_row - 3 & "   : " & Format((j - 3) / (last_row - 3), "0%")

        Application.Wait Now + TimeValue("0:00:01")
        Kill newPath & em.Cells(j, 2).Value & "*N.pdf"
        em.Cells(j, 9).Value = "Sent"

NextID:
    Next j

    MsgBox "All email has been sent", vbInformation

Exit_Err:
    'Release object memory
    Set NewMail = Nothing
    Set mailConfig = Nothing

    With Application
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .DisplayStatusBar = False
    End With
    Exit Sub

Err:
    Select Case Err.Number
        Case -2147220973  'Could be because of Internet Connection
            MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
        Case -2147220975  'Incorrect credentials User ID or password
            MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
        Case Else   'Report other errors
            MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
    End Select
    Resume Exit_Err
End Sub

[Priyantha]

Dear Hans,

Thanks, Your Code & try it. But I think, it is running up to below line only,
em.Cells(j, 9).Value = " Could Not Create Protected PDF"

All *.pdf files in "C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" have been protected with a password (without *.N.pdf files in that folder).


Thanks,

Priyantha

[HansV]

Apparently the line

Code: Select all

        retval = Shell("C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & strParam, 0)

fails, but I cannot help you with that. I don't know anything about pdftk.exe.

[Priyantha]

Dear Hans,

Thanks for your Attention,

It's an app I found to protect pdf files with passwords. (Eg. Before Protect PW: 37224N.pdf, After protecting a password as 37224.pdf). All files are protected with a password, so I think it works correctly & protected files (eg. 37224.pdf) are in the folder ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\").

Something happened, When running the macro the first time, not sent any massage & in the folder ("C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\") appeared both types of files, with the protected files (Eg. 37224.pdf), and the initial case of files (eg. 37224N.pdf) appeared in the "C:\Users\User\Desktop\Maling Payadvice\With Gmail 01\PaySlips\" folder.

When running the macro the second time, all messages were sent correctly & Only protected files are found in the folder. what is happening?

Link For Protector With PW:
https://www.pdflabs.com/tools/pdftk-the-pdf-toolkit/


Priyantha

[HansV]

I'm sorry, I cannot help you with this.

[Priyantha]

Dear Hans,

OK Thanks

[Priyantha]

Dear Hans,

I edit your code as below, then it is working, thanks your help again.

retval = Shell("C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & strParam, 0) '<<=== Percorso da adattare N.B. lo spazio dopo pdftk.exe

Application.Wait Now + TimeValue("0:00:02")

Attach_01 = newPath & filename_01 & ".pdf"
AttachExists_01 = Dir(Attach_01)
If AttachExists_01 = "" Then
em.Cells(j, 9).Value = " Could Not Create Protected
PDF"
GoTo NextID
End If

Priyantha

[HansV]

Glad you found a solution!