# [SOLVED] Macro to send email with PDF. MSExcel



## barcas84 (Nov 2, 2010)

Hi, I downloaded a macro from Internet that creates a new sheet. In that sheet you have multiple cells to fill in information and well, at then end it sends an email with a PDF file on it.

My problem is that the button to execute that macro is in the sheet 2 (the one that the macro created by itself) and I need it in the sheet 1. Sheet 1 is the only one visible, the rest of them are hidden... I made some changes so all the cells to fill in Sheet2, get the information from some cells in Sheet 1, but still I haven't moved the button yet, I tried different things but nothing...

Another option would be to create a new marco from scratch in Sheet 1, but it is a complicated macro and I've never done any in my life...:4-dontkno


----------



## barcas84 (Nov 2, 2010)

*Re: Macro to send email with PDF. MSExcel*

Never mind, that macro is not working.... I need to create one from scratch. 

So what I need is button to execute a macro. The button has to be in Sheet1. The macro has to do a PDF of Sheet2 and generate an email with outlook with the PDF attached. The name of the PDF file has to be "Quote". The email also has to have another file attached. The subject of the email, the body, the address, the CC, BC, and the URL of the file attached have to be in Sheet2...

I have no idea to do this, I really need help!


----------



## barcas84 (Nov 2, 2010)

*Re: Macro to send email with PDF. MSExcel*

Sorry I made a mistake, it has to be a PDF of sheet2, and the information of the email is in Sheet3, not Sheet2...


----------



## RSpecianjr (Jan 20, 2010)

*Re: Macro to send email with PDF. MSExcel*

Hey baracas,

Can you post the code you already had? It helps out a lot to have some code already written, even if it doesn't work. Just saves some time you know. Also, what version of Excel are you using? 2007?

Thanks,

Robert


----------



## barcas84 (Nov 2, 2010)

*Re: Macro to send email with PDF. MSExcel*

Hi Robert, I send you the code that this thing, that I downloaded from Internet, has... Hope it helps!! Oh, and I'm using the Excel 2007.




Private Sub RDB_Outlook_Click()
Dim StringTo As String, StringCC As String, StringBCC As String
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim DefPath As String
Dim olApp As Object
Dim olMail As Object
Dim FileExtStr As String

Dim ToArray As Variant
Dim CCArray As Variant
Dim BCCArray As Variant

Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean

If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailPDFOutlook"
Exit Sub
End If

If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
"protected or if you have more then sheet selected(grouped)", 48, "RDBMailPDFOutlook"
Exit Sub
End If

'Set folder where we save the temporary files
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

'Set reference to Outlook and turn of ScreenUpdating and Events
Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Set cells with Red interior color to no fill(cells with wrong data)
Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone

'Set rng to the first column of the table
Set rng = Me.Range("A6").ListObject.ListColumns(1).Range

For Each myCell In rng

'Create mail if "Yes " in column A
If LCase(myCell.Value) = "yes" Then

StringTo = "": StringCC = "": StringBCC = ""
S = 0: F = 0
Erase ShArr: Erase FArr

'Set Error Boolean to False
WrongData = False

'Check if there are Sheet names in column B

'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0

'If there are sheet names in the B column S is the number of sheets it add to the Array
If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
StringSheetNames = Me.Cells(myCell.Row, "B").Value
SheetNamesArray = Split(StringSheetNames, Chr(10), -1)

For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
On Error Resume Next
If SheetNamesArray(I) <> "" Then
If SheetExists(CStr(SheetNamesArray(I))) = False Then
Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
WrongData = True
Else
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = SheetNamesArray(I)
End If
End If
On Error GoTo 0
Next I
Else
'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
S = -1
End If

'Check to Mail addresses in column D
If Trim(Me.Cells(myCell.Row, "D").Value) <> "" Then
StringTo = Me.Cells(myCell.Row, "D").Value
ToArray = Split(StringTo, Chr(10), -1)
StringTo = ""

For I = LBound(ToArray) To UBound(ToArray)
If ToArray(I) Like "?*@?*.?*" Then
StringTo = StringTo & ";" & ToArray(I)
End If
Next I
End If

'Check to Mail addresses in column E
If Trim(Me.Cells(myCell.Row, "E").Value) <> "" Then
StringCC = Me.Cells(myCell.Row, "E").Value
CCArray = Split(StringCC, Chr(10), -1)
StringCC = ""

For I = LBound(CCArray) To UBound(CCArray)
If CCArray(I) Like "?*@?*.?*" Then
StringCC = StringCC & ";" & CCArray(I)
End If
Next I
End If

'Check to Mail addresses in column F
If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
StringBCC = Me.Cells(myCell.Row, "F").Value
BCCArray = Split(StringBCC, Chr(10), -1)
StringBCC = ""

For I = LBound(BCCArray) To UBound(BCCArray)
If BCCArray(I) Like "?*@?*.?*" Then
StringBCC = StringBCC & ";" & BCCArray(I)
End If
Next I
End If

If StringTo = "" And StringCC = "" And StringBCC = "" Then
Me.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
WrongData = True
End If

'Check the other files that you want to attach in column H
If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
StringFileNames = Me.Cells(myCell.Row, "H").Value
FileNamesArray = Split(StringFileNames, Chr(10), -1)

For I = LBound(FileNamesArray) To UBound(FileNamesArray)
On Error Resume Next
If FileNamesArray(I) <> "" Then
If Dir(FileNamesArray(I)) <> "" Then
If Err.number = 0 Then
F = F + 1
ReDim Preserve FArr(1 To F)
FArr(F) = FileNamesArray(I)
Else
Err.Clear
Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
WrongData = True
End If
Else
Me.Cells(myCell.Row, "H").Interior.ColorIndex = 3
WrongData = True
End If
End If
On Error GoTo 0
Next I
End If

'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
If WrongData = True Then GoTo MailNot


'Create PDF and Mail

'Create Date/time string for the file name
strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")

'Copy the sheet(s)to a new workbook
If S > 0 Then
ThisWorkbook.Sheets(ShArr).Copy
Set wb = ActiveWorkbook
End If

'You enter only "workbook" in colomn B to mail the whole workbook
'Use SaveCopyAs to make a copy of the workbook
If S = -1 Then
FileExtStr = "." & LCase(Right(ThisWorkbook.Name, _
Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
Fname2 = DefPath & "TempFile " & strDate & FileExtStr

ThisWorkbook.SaveCopyAs Fname2
Me.Activate
Set wb = Workbooks.Open(Fname2)
Application.DisplayAlerts = False
wb.Sheets(Me.Name).Delete
Application.DisplayAlerts = True
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If


'Now we Publish to PDF
If S <> 0 Then
Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
" " & strDate & ".pdf"

On Error Resume Next
wb.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
On Error GoTo 0
wb.Close False
Set wb = Nothing
End If

On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.BCC = StringBCC
.Subject = Me.Cells(myCell.Row, "G").Value
.Body = Me.Cells(myCell.Row, "I").Value
If S <> 0 Then .Attachments.Add Fname

If F > 0 Then
For I = LBound(FArr) To UBound(FArr)
.Attachments.Add FArr(I)
Next I
End If

'Set Importance 0 = Low, 2 = High, 1 = Normal
If LCase(Me.Cells(myCell.Row, "J").Value) = "yes" Then
.Importance = 2
End If

'Display the mail or send it directly, see cell C3
If LCase(Me.Range("C3").Value) = "yes" Then
.Display
Else
.Send
End If


End With

If S = -1 Then Kill Fname2
Kill Fname
On Error GoTo 0

Set olMail = Nothing

End If
MailNot:
Next myCell

If LCase(Me.Range("C3").Value) = "no" Then
MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
"If you see Red cells in the table then the information in the cells is " & vbNewLine & _
"not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
"Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
"Red cell or cells.", 48, "RDBMailPDFOutlook"
End If


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

Set olApp = Nothing
End Sub


Function SheetExists(wksName As String) As Boolean
On Error Resume Next
SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
On Error GoTo 0
End Function

Private Sub BrowseAddFiles_Click()
Dim Fname As Variant
Dim fnum As Long

If ActiveCell.Column = 8 And ActiveCell.Row > 6 Then
Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
MultiSelect:=True)
If IsArray(Fname) Then
For fnum = LBound(Fname) To UBound(Fname)
If fnum = 1 And ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
If Right(ActiveCell, 1) = Chr(10) Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
End If
End If
Next fnum

With Me.Range("J1").EntireColumn
.ColumnWidth = 255
.AutoFit
End With
With Me.Rows
.AutoFit
End With
End If
Else
MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailPDFOutlook"
End If
End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 3 And Target.Column < 7 And Target.Row > 6 Then
With Range(Target.Address)
.Hyperlinks.Delete
End With
End If
End Sub


----------



## RSpecianjr (Jan 20, 2010)

*Re: Macro to send email with PDF. MSExcel*

Hey Barcas,

Try this out:


```
Sub SendPDFViaOutlook()
Dim StringTo As String, StringCC As String, StringBCC As String, Fname As String, Fname1 As String
Dim wb1 As Workbook, wb2 As Workbook, sh As Worksheet
Dim DefPath As String
Dim olApp As Object
Dim olMail As Object
Dim FileExtStr As String

If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved once.", 48, "Mail PDF Outlook"
Exit Sub
End If

'Set folder where we save the temporary files
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

Fname1 = DefPath & "Quote"
Set wb1 = ActiveWorkbook
Set ws = wb1.Worksheets(2)

ws.Copy

Set wb2 = ActiveWorkbook
Fname = DefPath & "tempworkbook.xlsx"
wb2.SaveCopyAs Fname

On Error Resume Next
wb2.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Fname1, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
On Error GoTo 0
wb2.Close False
Set wb2 = Nothing

'Set reference to Outlook and turn off ScreenUpdating and Events
Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Set variables for parts of the email
'You may need to change these
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
StringTo = wb1.Worksheets(1).Range("B2").Value
StringCC = wb1.Worksheets(1).Range("B3").Value
StringSubject = wb1.Worksheets(1).Range("B4").Value
StringBody = wb1.Worksheets(1).Range("B5").Value
StringAttach = wb1.Worksheets(1).Range("B6").Value

'Set email parts to variables
'On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.Subject = StringSubject
.Body = StringBody
If StringAttach <> 0 Then .Attachments.Add StringAttach
.Attachments.Add Fname1 & ".pdf"
.Display
End With

End Sub
```
Alright, so this uses information from the first sheet to create the email. You will need to change the sheet and the range to the cells you want to use. I have noted the point in the macro you will need to change.

I took a lot of the error handling out, because you probably wont need it. If the cells are blank, then the corresponding part of the email is blank. The email is set to display at the end ".Display", if you want to automatically send it, the change it to ".Send".

Let me know if this is what your looking for or if you need something different.

Thanks,

Robert D. Specian Jr.


----------



## barcas84 (Nov 2, 2010)

*Re: Macro to send email with PDF. MSExcel*

This is sweet! Perfect! I made all the changes and it works perfect!!! Thank you so much Robert!!!

P.S. Oh, and I loved that you got rid of the control thing so I can send emails with some of the values blank!


----------



## barcas84 (Nov 2, 2010)

Hi Robert! My boss added something to this feature (of course...). Is there anyway to, besides sending the email with the code you gave me, also send an extra email to a different email address and that would have attached the first Sheet in PDF? 

You see, the code you gave me is to send an specific email to a client, which is a template that I made in Sheet 3 using some information from Sheet 1, but he wants to get a copy of the first Sheet with all the calculations in a different email... Oh, and this second email wouldn't have to have a preview, it would just send it... Is it possible?? Sorry to bother you again!!!


----------



## RSpecianjr (Jan 20, 2010)

Hey barcas,

No worries mate! Just duplicate the email part of the macro and change the sources to what you need. Only one line of code we need to add... and it should actually be in there anyway will be at the top and bottom (once for the previous mailer and once for the new mailer):


```
Set olMail = Nothing

StringTo = wb1.Worksheets(1).Range("B2").Value
StringCC = wb1.Worksheets(1).Range("B3").Value
StringSubject = wb1.Worksheets(1).Range("B4").Value
StringBody = wb1.Worksheets(1).Range("B5").Value
StringAttach = wb1.Worksheets(1).Range("B6").Value

'Set email parts to variables
'On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.Subject = StringSubject
.Body = StringBody
If StringAttach <> 0 Then .Attachments.Add StringAttach
.Attachments.Add Fname1 & ".pdf"
.Send 'instead of .Display

Set olMail = Nothing

End With
```
So, just copy and paste this right above the End Sub and change the variable sources. Or get rid of the variables and do it directly, if it doesn't change that could be better. ie:


```
.To = "[email protected]"
.CC = "[email protected]" 'or just delete the CC if your not going to use it.
.Subject = "the subject of the email"
.Body = "the body of the email"
.Attachments.add "Full/path/and/file/extension.pdf"
.Send
```
Just let me know if you run into any problems.

Hope this helps,

Robert


----------



## barcas84 (Nov 2, 2010)

Hey!! I did that, and also I added a new Fname2, because I needed the Sheet1 (not Sheet3) as a PDF in the second mailer, and it worked perfectly!!!!!!!

Thank you so much man!


----------



## RSpecianjr (Jan 20, 2010)

Cheers mate = )


----------



## barcas84 (Nov 2, 2010)

Actually, if I have Fname1 and Fname2, how can I add both into the email?


----------



## RSpecianjr (Jan 20, 2010)

Hey Barcas,

Just add another attachments.add to the email you want both on.

.Attachments.Add Fname1 & ".pdf"
.Attachments.Add Fname2 & ".pdf"

Regards,

Robert D. Specian Jr.


----------



## barcas84 (Nov 2, 2010)

Perrrrfect! Thank you so much! That was the last thing!!!!!!


----------



## barcas84 (Nov 2, 2010)

Hey Robert here I am again!!!!!

I have an issue, because I forgot to mention something. In this macro and also in the one that just generate the PDF of a Sheet... How can I make them to work if the Sheets are hidden?


----------



## RSpecianjr (Jan 20, 2010)

Hey barcas,

You have to unhide the sheet first and then hide it again at the end.


```
Sheet1.Visible = False
```
and 


```
Sheet1.Visible = True
```
Hope this helps,

Robert D. Specian Jr.


----------



## barcas84 (Nov 2, 2010)

Hi, Robert!

And where do I put that code? First line at the beginning right after the Sub, and the second line at the very end?


----------



## RSpecianjr (Jan 20, 2010)

Exactly, it doesn't really make a difference where as long as it encompasses the code related to the worksheet in question. 

First line after Sub... and last line before End Sub


----------



## barcas84 (Nov 2, 2010)

This is perfect!!!! Thank you so much, AGAIN! It works!


----------

