• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

send pdf file not working in office 2016

abdulncr

Member
Dear Friends,

I have below code to send PDF files from the path address given, it was working perfectly.

after upgrading to office 2016, it is not working at all. any help please...

Code:
Sub Send_Row_Or_Rows_pdf_Attachment_1()
If MsgBox(" Please make sure, you want to send the email to all the Customer?", vbYesNo) = vbNo Then Exit Sub 'Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim cell As Range
Dim sMsg As String
Dim ccmailAddress
Dim rngPDF As Range, cellPDF As Range  '<=== added

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
  .EnableEvents = False
  .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A17:J" & Ash.Rows.Count)
FieldNum = 3  'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Cws.Range("B1"), _
  CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(2))

'If there are unique values start the loop
If Rcount >= 2 Then
  For Rnum = 2 To Rcount

  'Look for the mail address in the MailInfo worksheet
  mailAddress = ""
  On Error Resume Next
  mailAddress = Application.WorksheetFunction. _
  VLookup(Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:B" & _
  Worksheets("Mailinfo").Rows.Count), 2, False)
  
  ' added code to get CC address from column C
  ccmailAddress = Application.WorksheetFunction. _
  VLookup(Cws.Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:C" & _
  Worksheets("Mailinfo").Rows.Count), 3, False)
  
  ' Build the Message
  sMsg = ""
  For Each cell In Worksheets("Mailinfo").Range("J5:J25")
  sMsg = sMsg & cell.Value & vbNewLine
  Next
  On Error GoTo 0

  If mailAddress <> "" Then

  'Filter the FilterRange on the FieldNum column
  FilterRange.AutoFilter Field:=FieldNum, _
  Criteria1:=Cws.Cells(Rnum, 2).Value

  'Copy the visible data in a new workbook
  With Ash.AutoFilter.Range
  On Error Resume Next
  Set rng = .SpecialCells(xlCellTypeVisible)
  Set rngPDF = Intersect(rng.EntireRow, Ash.Range("N:N"))  '<== added
  On Error GoTo 0
  End With
  
  Set NewWB = Workbooks.Add(xlWBATWorksheet)
  ActiveWindow.DisplayGridlines = False
  
  rng.Copy
  With NewWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
  End With

  'Create a file name
  TempFilePath = Environ$("temp") & "\"
  TempFileName = " " & Ash.Parent.Name _
  & " " & format(Now, "dd-mmm-yy h-mm-ss")
  
  
  If Val(Application.Version) < 10 Then
  'You use Excel 2000-2003
  FileExtStr = ".xls": FileFormatNum = -4143
  Else
  'You use Excel 2007-2010
  FileExtStr = ".xlsx": FileFormatNum = 51
  End If
  
  'Save, Mail, Close and Delete the file
  Set OutMail = OutApp.CreateItem(0)

  With NewWB
  .SaveAs TempFilePath & TempFileName _
  & FileExtStr, FileFormat:=FileFormatNum
  On Error Resume Next
  With OutMail
  .To = mailAddress
  .cc = ccmailAddress  '<==  added
  .Subject = "Invoice for the " _
  & Cws.Cells(Rnum, 2).Value  '<=== changed
  ' .Attachments.Add NewWB.FullName
  For Each cellPDF In rngPDF  '<==== added
  .Attachments.Add cellPDF.Value  '<==== added
  Next  '<==== added
  .Body = sMsg  '<=== changed
  
  .Display
  Application.Wait (Now + TimeValue("0:00:01"))
  Application.SendKeys "%s"
  End With
  On Error GoTo 0
  .Close savechanges:=False
  End With

  Set OutMail = Nothing
  Kill TempFilePath & TempFileName & FileExtStr
  End If

  'Close AutoFilter
  Ash.AutoFilterMode = False

  Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
End Sub


Thanks
Abaad
 
Hi ,

When you say
it is not working at all.
, what exactly happens ?

Does the procedure execute without any error messages ? Is there no output ?

As a first step , remove / comment out all the On Error .... statements , and then run the procedure.

I really cannot help any further , since I do not have Excel 2016.

Only those who have Excel 2016 may be in a position to help.

Narayan
 
I don't see any 2016 issues. Of course I would need a simple obfuscated file that has the problem to test and know for sure.

I avoid SendKeys() whenever possible. Why not skip .Display, Wait, and SendKeys and just use .Send?

You might want to check if the pdf file exists before adding. e.g.
Code:
If Dir(cellPDF.Value) <> "" Then .Attachments.Add cellPDF.Value '<==== added
 
Dear Narayanan,

Sorry, I was sick and off for two days.

Thank you for your response

No error message is popping, just end the procedure within 4 second without any action.
already commented on On error..., still no error message.

I tried to debug the code, each time variable value I checked in immediate window, it is updating correctly. when reaching .Display, it is not opening outlook. unable to make out what is the issue.

Thanks
Abaad
 
I don't see any 2016 issues. Of course I would need a simple obfuscated file that has the problem to test and know for sure.

I avoid SendKeys() whenever possible. Why not skip .Display, Wait, and SendKeys and just use .Send?

You might want to check if the pdf file exists before adding. e.g.
Code:
If Dir(cellPDF.Value) <> "" Then .Attachments.Add cellPDF.Value '<==== added

Dear Kenneth,

Thank you for your time.
I checked the PDF file in the path, it is existing.

As required, please find the sample file attached here with.

Request your help on the same.

Thanks
Abaad
 

Attachments

  • SendEmail.xlsm
    175 KB · Views: 5
Since you did not include the VBAProject password, I copied the sheets and used the code from post #1.

I think the only problem I saw was when the file did not exist.
Code:
Sub Send_Row_Or_Rows_pdf_Attachment_1()
If MsgBox(" Please make sure, you want to send the email to all the Customer?", vbYesNo) = vbNo Then Exit Sub 'Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim cell As Range
Dim sMsg As String
Dim ccmailAddress
Dim rngPDF As Range, cellPDF As Range  '<=== added

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
  .EnableEvents = False
  .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A17:J" & Ash.Rows.Count)
FieldNum = 3  'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Cws.Range("B1"), _
  CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(2))

'If there are unique values start the loop
If Rcount >= 2 Then
  For Rnum = 2 To Rcount

  'Look for the mail address in the MailInfo worksheet
  mailAddress = ""
  On Error Resume Next
  mailAddress = Application.WorksheetFunction. _
  VLookup(Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:B" & _
  Worksheets("Mailinfo").Rows.Count), 2, False)
 
  ' added code to get CC address from column C
ccmailAddress = Application.WorksheetFunction. _
  VLookup(Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:C" & _
  Worksheets("Mailinfo").Rows.Count), 3, False)
 
  ' Build the Message
sMsg = ""
  For Each cell In Worksheets("Mailinfo").Range("J5:J25")
  sMsg = sMsg & cell.Value & vbNewLine
  Next
  On Error GoTo 0

  If mailAddress <> "" Then

  'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
  Criteria1:=Cws.Cells(Rnum, 2).Value

  'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
  On Error Resume Next
  Set rng = .SpecialCells(xlCellTypeVisible)
  Set rngPDF = Intersect(rng.EntireRow, Ash.Range("N:N"))  '<== added
On Error GoTo 0
  End With
 
  Set NewWB = Workbooks.Add(xlWBATWorksheet)
  ActiveWindow.DisplayGridlines = False
 
  rng.Copy
  With NewWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
  End With

  'Create a file name
TempFilePath = Environ$("temp") & "\"
  TempFileName = " " & Ash.Parent.Name _
  & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
 
  If Val(Application.Version) < 10 Then
  'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
  Else
  'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
  End If
 
  'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

  With NewWB
  .SaveAs TempFilePath & TempFileName _
  & FileExtStr, FileFormat:=FileFormatNum
  On Error Resume Next
  With OutMail
  .To = mailAddress
  '.cc = ccmailAddress
  If ccmailAddress <> "" Then .cc = ccmailAddress '<==  added
.Subject = "Invoice for the " _
  & Cws.Cells(Rnum, 2).Value  '<=== changed
' .Attachments.Add NewWB.FullName
For Each cellPDF In rngPDF  '<==== added
If Dir(cellPDF.Value) <> "" Then .Attachments.Add cellPDF.Value '<==== added
Next  '<==== added
.Body = sMsg  '<=== changed
  .Display
  Application.Wait (Now + TimeValue("0:00:02"))
  Application.SendKeys "%s"
  '.send
  End With
  On Error GoTo 0
  .Close savechanges:=False
  End With

  Set OutMail = Nothing
  Kill TempFilePath & TempFileName & FileExtStr
  End If

  'Close AutoFilter
Ash.AutoFilterMode = False

  Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
End Sub
 
Since you did not include the VBAProject password, I copied the sheets and used the code from post #1.

I think the only problem I saw was when the file did not exist.
Code:
Sub Send_Row_Or_Rows_pdf_Attachment_1()
If MsgBox(" Please make sure, you want to send the email to all the Customer?", vbYesNo) = vbNo Then Exit Sub 'Working in 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim cell As Range
Dim sMsg As String
Dim ccmailAddress
Dim rngPDF As Range, cellPDF As Range  '<=== added

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
  .EnableEvents = False
  .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A17:J" & Ash.Rows.Count)
FieldNum = 3  'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
  Action:=xlFilterCopy, _
  CopyToRange:=Cws.Range("B1"), _
  CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(2))

'If there are unique values start the loop
If Rcount >= 2 Then
  For Rnum = 2 To Rcount

  'Look for the mail address in the MailInfo worksheet
  mailAddress = ""
  On Error Resume Next
  mailAddress = Application.WorksheetFunction. _
  VLookup(Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:B" & _
  Worksheets("Mailinfo").Rows.Count), 2, False)

  ' added code to get CC address from column C
ccmailAddress = Application.WorksheetFunction. _
  VLookup(Cells(Rnum, 2).Value, _
  Worksheets("Mailinfo").Range("A3:C" & _
  Worksheets("Mailinfo").Rows.Count), 3, False)

  ' Build the Message
sMsg = ""
  For Each cell In Worksheets("Mailinfo").Range("J5:J25")
  sMsg = sMsg & cell.Value & vbNewLine
  Next
  On Error GoTo 0

  If mailAddress <> "" Then

  'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
  Criteria1:=Cws.Cells(Rnum, 2).Value

  'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
  On Error Resume Next
  Set rng = .SpecialCells(xlCellTypeVisible)
  Set rngPDF = Intersect(rng.EntireRow, Ash.Range("N:N"))  '<== added
On Error GoTo 0
  End With

  Set NewWB = Workbooks.Add(xlWBATWorksheet)
  ActiveWindow.DisplayGridlines = False

  rng.Copy
  With NewWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteValues
  .Cells(1).PasteSpecial Paste:=xlPasteFormats
  .Cells(1).Select
  Application.CutCopyMode = False
  End With

  'Create a file name
TempFilePath = Environ$("temp") & "\"
  TempFileName = " " & Ash.Parent.Name _
  & " " & Format(Now, "dd-mmm-yy h-mm-ss")


  If Val(Application.Version) < 10 Then
  'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
  Else
  'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
  End If

  'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

  With NewWB
  .SaveAs TempFilePath & TempFileName _
  & FileExtStr, FileFormat:=FileFormatNum
  On Error Resume Next
  With OutMail
  .To = mailAddress
  '.cc = ccmailAddress
  If ccmailAddress <> "" Then .cc = ccmailAddress '<==  added
.Subject = "Invoice for the " _
  & Cws.Cells(Rnum, 2).Value  '<=== changed
' .Attachments.Add NewWB.FullName
For Each cellPDF In rngPDF  '<==== added
If Dir(cellPDF.Value) <> "" Then .Attachments.Add cellPDF.Value '<==== added
Next  '<==== added
.Body = sMsg  '<=== changed
  .Display
  Application.Wait (Now + TimeValue("0:00:02"))
  Application.SendKeys "%s"
  '.send
  End With
  On Error GoTo 0
  .Close savechanges:=False
  End With

  Set OutMail = Nothing
  Kill TempFilePath & TempFileName & FileExtStr
  End If

  'Close AutoFilter
Ash.AutoFilterMode = False

  Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
End Sub

Thank you Kenneth for your help.
sorry, I missed the pw, I attached file after removing the pw.
PDF file saved in the same folder in path, same can be seen on search after copy paste path address in the search.

when I run the macro line by line with F8, .Display not bringing opening outlook, I think even the file is not found, it is supposed open outlook.

Thanks
Abaad
 

Attachments

  • SendEmail.xlsm
    175.3 KB · Views: 3
Back
Top