Add current worksheet as pdf to gmail
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
Code:
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
Composing name with cells' content...
Quote:
Originally Posted by
mdmackillop
Change
Code:
' 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
Code:
' 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:
Code:
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
1004 Error unexplainable (to me)!
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
Code:
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
