Add current worksheet as pdf to gmail

[eisse]

Hello,

For my company i am busy to automate the invoice system. The main goal is:
- to convert a brochure to a invoice (done)
- The next thing is to make sure the invoicenumbers keep ascending (done)/ Save the invoice as pdf file(done)
- Send the specific invoice to the customer through Gmail
The last is the thing i cant get done.

I already know how to send a new message by Gmail with a text by clicking a button in Excel but the problem is i am stuck at sending the specific invoice to the customer.

Is there a way to choose a file to attach to the mail or is there a way to send the current worksheet(invoice) and at the same time save this invoice on the pc as pdf?

i am pretty new with vba so i dont know what to do anymore



Sub send_email_via_Gmail()

Dim myMail As CDO.Message

Set myMail = New CDO.Message

' i deleted the Http :// in the following rules because i could not post links because this is my first post

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/smtpusessl") = True

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/smtpauthenticate") = 1

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/smtpserver") = "smtp.gmail"

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/smtpserverport") = 25

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/sendusing") = 2

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/sendusername") = "company mail adres"

myMail.Configuration.Fields.Item("schemas.microsoft. com/cdo/configuration/sendpassword") = "password"

myMail.Configuration.Fields.Update

With myMail
.Subject = "Test Email from eisse"
.From = """company name"" <company mail adres>"
.To = "my mail adress"
.CC = ""
.BCC = ""
.HTMLBody = the text to put in the mail
.AddAttachment "C:/users/eisse/desktop/invoice 3.pdf"
End With
On Error Resume Next
myMail.Send
'MsgBox("Mail has been sent")
Set myMail = Nothing

End Sub

[offthelip]

This routine will allow the user to select afile:


Sub testsel()
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim fDialog As FileDialog
Path = ActiveWorkbook.Path & "\"


Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Optional: FileDialog properties
fDialog.AllowMultiSelect = False
fDialog.Title = "Select a file"
fDialog.InitialFileName = Path
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
fileselected = fDialog.SelectedItems(1)
fname = FSO.GetFileName(fileselected) 'The file name
End If
MsgBox fname



End Sub

[Leith Ross]

Hello eisse,

This macro will save the Activesheet as a PDF file to your Desktop. Edit the Email Information and Gmail Account Information sections to match your needs.



Option Explicit


' Author: Leith Ross
' Written: August 06, 2017
' Summary: This macro will save the ActiveSheet to the User's Desktop and then send it in the email as an attachment.
'
' Update: August 07, 2017 - For CDO to work with Google's new security measures, you must first enable "Less Secure Apps".
' This can be done by accessing this page from your browser: https://myaccount.google.com/lesssecureapps?pli=1
'
' If you do not then you will receive the following error message...
' *************************************************************************** ****'
' / Run-time error '-2147220975 (800400211)': /
' / /
' / The message could not be sent to the SMTP server. The transport /
' / error code was 0x80040217. The server was not available. /
' *************************************************************************** ****'


Sub SendGmailPDF()


Dim File As String
Dim Folder As Variant
Dim cdoNS As String
Dim cdoMsg As Object
Dim htmlMsg As String
Dim Password As String
Dim strBCC As String
Dim strCC As String
Dim strMsg As String
Dim strSubj As String
Dim strTo As String
Dim UserEmail As String

' Email Information.
strTo = ""
strSubj = ""
strMsg = ""
strCC = ""
strBCC = ""

' Gmail Account Information.
UserEmail = "me@gmail.com"
Password = "my_password"

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email.
With CreateObject("Shell.Application")
Folder = .Namespace(0).Self.Path & "\"
File = Folder & ActiveWorkbook.Name
File = Left(File, InStrRev(File, ".")) & "pdf"
ActiveSheet.Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=File
ActiveWorkbook.Close SaveChanges:=False
End With"

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

Set cdoMsg = CreateObject("CDO.Message")


With cdoMsg
.To = strTo
.Subject = strSubj
.From = UserEmail
.CC = strCC
.BCC = strBCC
.TextBody = strBody
.AddAttachment File

With .Configuration.Fields
.Item(cdoNS & "smtpusessl") = True ' Any non zero value is True
.Item(cdoNS & "smtpauthenticate") = 1 ' basic clear text
.Item(cdoNS & "sendusername") = UserEmail
.Item(cdoNS & "sendpassword") = Password
.Item(cdoNS & "smtpserver") = "smtp.gmail.com"
.Item(cdoNS & "sendusing") = 2 ' Using Port
.Item(cdoNS & "smtpserverport") = 465 ' Gmail SMTP Port
.Item(cdoNS & "smtpconnectiontimeout") = 60
.Update
End With

.Send
End With

End Sub

[YasserKhalil]

Thanks a lot Mr. Leith for this awesome code .. You are a legend

[eisse]

Thank you very much Leith, it works perfectly, then a another simple question(a)

Is there a possibility possibility to change te name of the attachment?

[mdmackillop]

"File" is a variable. You can set it to whatever you want.
1. Derived from the code as shown
File = Folder & ActiveWorkbook.Name
File = Left(File, InStrRev(File, ".")) & "pdf"
2. Hard coded to a specific name e.g. File = "C:\Test\Test.pdf"
3. Allows you to pick e.g. File = Application.GetOpenFilename()

What are you after?

[eisse]

Well, i want to change the name of the file to invoice + the name of the customer(so cell value related) + an invoicenumber (also cell related) instead of the name of the excel file

[mdmackillop]

Something like

file = ActiveWorkbook.Path & "\" & "Invoice_" & Sheets("Sheet1").[A1] & "_" & Sheets("Sheet1").[A2] & ".pdf"

[eisse]

that does not seem to work unfortunately

[mdmackillop]

Add Debug.print File and check the output in the Immediate window or post your workbook

[eisse]

I used the exact code that Leith Ross posted and of course filled in my data for mail, password, subject etc.

And the name i want to use for my attachment ="Verduurzaming woning + name(sheet "invoice" cell A2) + invoicenumber (sheet "invoice" cell C11)

[mdmackillop]

Change

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email. With CreateObject("Shell.Application")
Folder = .Namespace(0).Self.Path & "\"
File = Folder & ActiveWorkbook.Name
File = Left(File, InStrRev(File, ".")) & "pdf"
ActiveSheet.Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=File
ActiveWorkbook.Close SaveChanges:=False
End With
to

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email.
file = ActiveWorkbook.Path & "\" & "Verduurzaming woning" & "_" & Sheets("invoice").[A2] & "_" & Sheets("invoice").[C11] & ".pdf"
Debug.Print file
ActiveSheet.Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=file
ActiveWorkbook.Close SaveChanges:=False

This creates, for me, a file called "F:\Verduurzaming woning_MDMacKillop_1234.pdf"
Ensure that you have no illegal characters in your invoice number. e.g. "12/1234"

[eisse]

Thank you very much, it works! If i may ask i have one last Question.
How can i set the receiver of the mail based on a specific cell?

[mdmackillop]

In specified cell
John Smith <JS@gmail.com>

If you want a greeting

strbody = "Hi " & Split(Sheets("Invoice").[C12])(0) & vbCr & vbCr & strbody

With cdoMsg
.To = Sheets("Invoice").[C12]

[mdmackillop]

See similar thread here (http://www.vbaexpress.com/forum/showthread.php?60329-Macro-to-Copy-certain-WS-s-based-on-Key-to-a-New-WB-and-email)

[santosonit]

Awesome stuff here!
Two needs I can't get my head around:
01 - How to have it export only until the row where there is visible data;
02 - How to export it without cells' borders, since visually, there's visually no border.

Appreciate you sharing this!

Cheers,

[Leith Ross]

Hello santosonit,

In question 01 did you mean until there is NO visible data?

Can you post attachments showing before and after examples of the cell borders?

[santosonit]

Hello santosonit,

In question 01 did you mean until there is NO visible data?

Can you post attachments showing before and after examples of the cell borders?


Hello Leith,
I actually ended up using the code below to limit the report to where there is visible data:

If ActiveSheet.Range("A17").Value = "" Then
lastrow = 16
Application.EnableEvents = False
Else
lastrow = Range("A17").End(xlDown).Row
End If
Application.EnableEvents = True
ActiveSheet.Range("A1:K" & lastrow).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False

As to the second question, I've found out that this is a confirguration change required at Excel's end.

Thank you for the help!

[santosonit]

Change

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email. With CreateObject("Shell.Application")
Folder = .Namespace(0).Self.Path & "\"
File = Folder & ActiveWorkbook.Name
File = Left(File, InStrRev(File, ".")) & "pdf"
ActiveSheet.Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=File
ActiveWorkbook.Close SaveChanges:=False
End With
to

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email.
file = ActiveWorkbook.Path & "\" & "Verduurzaming woning" & "_" & Sheets("invoice").[A2] & "_" & Sheets("invoice").[C11] & ".pdf"
Debug.Print file
ActiveSheet.Copy
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=file
ActiveWorkbook.Close SaveChanges:=False

This creates, for me, a file called "F:\Verduurzaming woning_MDMacKillop_1234.pdf"
Ensure that you have no illegal characters in your invoice number. e.g. "12/1234"

Hello Leith,
After I've implemented your code + a couple of additions, I keep getting a pop up window with error 400:


If UserEmail = "" Or Password = "" Then
MsgBox "Informe seu email e senha!"
Exit Sub
Else
With CreateObject("Shell.Application")
'Folder = .Namespace(0).Self.Path & "\"
File = ActiveWorkbook.Path & "\" & "Relatório de Comissao" & Sheets("Relatório de Comissão").[B5] & "_" & Sheets("Relatório de Comissão").[B8] & ".pdf"
'File = Left(File, InStrRev(File, ".")) & "pdf"
If ActiveSheet.Range("A17").Value = "" Then
lastrow = 16
MsgBox "Não há comissão no período!"
Exit Sub
Application.EnableEvents = False
Else
lastrow = Range("A17").End(xlDown).Row
End If
Application.EnableEvents = True
ActiveSheet.Range("A1:K" & lastrow).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False
'ActiveWorkbook.Close SaveChanges:=False
RelatorioComissao.Range("B5").Select

End With

What I am trying to achieve is to the file name saved with a name composed by some of the cells' contents, but I'm not sure my if statement(s) are causing Shell.Application to break.
Although you've done much already, could you please help on this one, too?

Cheers,
Antonio

[Leith Ross]

Hello Antonio,

Error code 400 in VBA is a "catch-all" error code. It is not informative about the cause and be very hard to pinpoint why it is happening.

The way the code is written now, the Application.Shell is redundant. I have re-written your code to make is easier to read and consolidated some of the code.



Sub ExampleA()


If UserEmail = "" Or Password = "" Then
MsgBox "Informe seu email e senha!"
GoTo Finished
End If

File = ActiveWorkbook.Path & "\" & "Relatório de Comissao" & Sheets("Relatório de Comissão").[B5] & "_" & Sheets("Relatório de Comissão").[B8] & ".pdf"
If ActiveSheet.Range("A17").Value = "" Then
lastrow = 16
MsgBox "Não há comissão no período!"
GoTo Finsished
Else
lastrow = Range("A17").End(xlDown).Row
End If

ActiveSheet.Range("A1:K" & lastrow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False

RelatorioComissao.Range("B5").Select

Finished:
Application.EnableEvents = True

End Sub


This is presented to show you where the code would be placed in reference to the End Sub statement. You did not show the full If statement, so I can not be sure this wholly correct. Let me know what happens.

Guma math a théid leat!
(Good luck to you!)

[santosonit]

Hello Leith,
Sorry to bother with this one, despiet all the help!
It's giving me an error 1004 - Application or Object Related

Sub SendGmailPDF()



Dim File As String
Dim Folder As Variant
Dim cdoNS As String
Dim cdoMsg As Object
Dim htmlMsg As String
Dim Password As String
Dim strBCC As String
Dim strCC As String
Dim strMsg As String
Dim strSubj As String
Dim ReplyTo As String
Dim strTo As String
Dim UserEmail As String
Dim RelatorioComissao As Worksheet
Dim LastRowResults As Range
Dim lastrow As Long
Dim Data As Date

Set RelatorioComissao = Worksheets("Relatório de Comissão")
Data = RelatorioComissao.Range("B8").Value




' Email Information.
strTo = RelatorioComissao.Range("B6").Value
strSubj = "Relatório de Comissão" & "-" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy")
strMsg = "Em anexo, segue o relatório de comissão. Sugerimos que revisem os detalhes."
strCC = "Email"
strBCC = ""
ReplyTo = "Email"

' Gmail Account Information.
UserEmail = RelatorioComissao.Range("B3").Value
Password = RelatorioComissao.Range("B4").Value

' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email.
If UserEmail = "" Or Password = "" Then
MsgBox "Informe seu email e senha!"
Exit Sub
End If
'Application.EnableEvents = False
File = "Relatório de Comissão" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy") & ".pdf"
If ActiveSheet.Range("A17").Value = "" Then
lastrow = 16
MsgBox "Não há comissão no período!"
Exit Sub
Else
lastrow = Range("A17").End(xlDown).Row
End If

'Application.EnableEvents = True

ActiveSheet.Range("A1:K" & lastrow).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False
'ActiveWorkbook.Close SaveChanges:=False




Set cdoMsg = CreateObject("CDO.Message")




With cdoMsg
.To = strTo
.Subject = strSubj
.From = UserEmail
.ReplyTo = ReplyTo
.CC = strCC
.BCC = strBCC

.TextBody = strMsg
.AddAttachment File

With .Configuration.Fields
.Item(cdoNS & "smtpusessl") = True ' Any non zero value is True
.Item(cdoNS & "smtpauthenticate") = 1 ' basic clear text
.Item(cdoNS & "sendusername") = UserEmail
.Item(cdoNS & "sendpassword") = Password
.Item(cdoNS & "smtpserver") = "smtp.gmail.com"
.Item(cdoNS & "sendusing") = 2 ' Using Port
.Item(cdoNS & "smtpserverport") = 465 ' Gmail SMTP Port
.Item(cdoNS & "smtpconnectiontimeout") = 60
.Update
End With

.Send

End With

End Sub
thanks a million!

[santosonit]

Hello Leith,

The error is within the piece below. It evens shows as it's publishing, but then the error window pops pup, saying that it's an object or application definition related error...
Thanks in advance for your attention/help!

Piece of Code reffered by the Debugger:
RelatorioComissao.Range("A1:K" & lastrow).ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=File, _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False



Sub SendGmailPDF()




Dim File As String
Dim Folder As Variant
Dim cdoNS As String
Dim cdoMsg As Object
Dim htmlMsg As String
Dim Password As String
Dim strBCC As String
Dim strCC As String
Dim strMsg As String
Dim strSubj As String
Dim strTo As String
Dim UserEmail As String
Dim RelatorioComissao As Worksheet
Dim LastRowResults As Range
Dim lastrow As Long
Dim Data As Date
Dim List As String
Dim Rng As Range


Set RelatorioComissao = ActiveWorkbook.Sheets("Relatório de Comissão")
Data = RelatorioComissao.Range("B8").Value

' Email Information.
strTo = RelatorioComissao.Range("B6").Value
strSubj = "Relatório de Comissão" & "-" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy")
strMsg = "Em anexo, segue o relatório de comissão. Sugerimos que revisem os detalhes."
strCC = ""
strBCC = ""
ReplyTo = "Email"
' Gmail Account Information.
UserEmail = RelatorioComissao.Range("B3").Value
Password = RelatorioComissao.Range("B4").Value


If UserEmail = "" Or Password = "" Then
MsgBox "Informe seu email e senha!"
Exit Sub
End If

File = "Relatório de Comissão" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy") & ".pdf"
If RelatorioComissao.Range("A17").Value = "" Then
lastrow = 16
MsgBox "Não há comissão no período!"
Exit Sub
Else
'lastrow = Cells(Rows.Count, "K").End(xlUp).Row

lastrow = Range("A" & ActiveSheet.Rows.Count).End(xlDown).Row
'lastrow = RelatorioComissao.Cells(Rows.Count, 1).End(xlUp).Row
End If


MsgBox lastrow

RelatorioComissao.Range("A1:K" & lastrow).ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=File, _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False

'ActiveSheet.Range("A1:K" & lastrow).Select
'Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False






Set cdoMsg = CreateObject("CDO.Message")




With cdoMsg
.To = strTo
.Subject = strSubj
.From = UserEmail
.ReplyTo = ReplyTo
.CC = strCC
.BCC = strBCC
.TextBody = strMsg
.AddAttachment File

With .Configuration.Fields
.Item(cdoNS & "smtpusessl") = True ' Any non zero value is True
.Item(cdoNS & "smtpauthenticate") = 1 ' basic clear text
.Item(cdoNS & "sendusername") = UserEmail
.Item(cdoNS & "sendpassword") = Password
.Item(cdoNS & "smtpserver") = "smtp.gmail.com"
.Item(cdoNS & "sendusing") = 2 ' Using Port
.Item(cdoNS & "smtpserverport") = 465 ' Gmail SMTP Port
.Item(cdoNS & "smtpconnectiontimeout") = 60
.Update
End With

.Send
End With
End Sub

[santosonit]

I got it to work basically using your instructions!
Again, thanks a million!

Cheers,
Antonio
PS: if you think that providing the solution here is of any help to others, let me know and I will do it with pleasure.

[Leith Ross]

Hello santosonit,

I would like to know the what the problem was and what you did to fix it. I have never this error before. Thanks.

[santosonit]

Hello santosonit,

I would like to know the what the problem was and what you did to fix it. I have never this error before. Thanks.


Hello Leith,

Here's how I've fixed it:


If RelComissao.Range("A17").Value =""Then
lastrow =16
MsgBox "Não há comissão no período!"
ExitSub
Else
lastrow = Range("A"& ActiveSheet.Rows.Count).End(xlUp).Row
EndIf

With CreateObject("Shell.Application")
Folder =.Namespace(0).Self.Path &""
File = Folder & ActiveWorkbook.Name
File = File & RelComissao.Range("B5").Value &"-"& Format(Data,"mmm-yy")&".pdf"
RelComissao.Range("A1:K"& lastrow).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File
EndWith

I think that because I hadn't specified a place where the file should be exported to, AddAttachment couldn't catch it and the code got stuck there. Also, I changed the way lastrow was detected.

I'm sorry, I'm not a developer and can't go any deeper (concept wise) why this solution worked.

Thank you!