Create pdf and send email through Outlook using VBA- HELP!

needhelpvba

New Member
Joined
Jun 16, 2013
Messages
7
Hi,

I've spent several hours (even days) on this but I'm still stuck. So my manager wanted to have a code for the Send Emails button below that would allow him to create the pdf files for the sheets specified in B7 and send them as attachments to addresses in D7-F7. It works fine for just one sheet but not two or more sheets. The sheets are separated by Alt+Enter (chr(10)). Please help! I would really appreciate it!

cxn.png


Option Explicit


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))


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 " & 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) & _
" " & ".pdf"


On Error Resume Next
wb.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
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
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Have you had a look at Ron De Bruins site regarding sending e-mails to multiple recipients.
www.rondebruin.nl/sendmail

I'd also consider splitting the E-mail addresses to remove the ALT + Enter
 
Upvote 0
Hi Michael. Yes I have taken a look at the website and couldn't find the answer. Also, I'm trying to attach multiple sheets to the email, not send to multiple recipients. Sorry for the confusion. Thanks for your help though, Michael!
 
Upvote 0
Ok, I'd suggest then, that you post a sample of the data layout, either here or uploaded to a site like dropbox and then post a link back here.
If the sheet names are in one cell and the list of names are in one cell....I can see a bit of work involved.
I usually use an input box or message box to allow the user to select the files from explorer rather than have a list on the worksheet.
 
Upvote 0
Michael M,

Thank you so much for your help! I've figured it out so I'll mark it resolved now. The problem lied with the FileName cell; it simply doesn't accept Alt+Enter as a delimiter. Thanks again, Michael! :)

Ok, I'd suggest then, that you post a sample of the data layout, either here or uploaded to a site like dropbox and then post a link back here.
If the sheet names are in one cell and the list of names are in one cell....I can see a bit of work involved.
I usually use an input box or message box to allow the user to select the files from explorer rather than have a list on the worksheet.
 
Upvote 0
HI ,

Please help me ,

Actually i have 1700 Pdf file in an folder regarding form 16 and 16A, and i have maintain an excel file , i share with you
Employee Code NameEmail IdPath
1350 Rajinder PrasadRajinder.yadav1980@gmail.comC:\New Folder\From 16

<tbody>
</tbody>

would you please help me to give VBA Coding that its pick PDF file from folder employee code wise and send a mail with respective email address via outlook .

i am highly appreciated if some body help me please ................
 
Last edited:
Upvote 0
Dear Sir,

Thanks but its not pick file employee code wise, would you please send me fresh VBA coding if u don't mind .
its a gr8 help for me . please ..........
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top