Unable to give destination folder as cell address in VBA to create pdf and mail

[princesethi2]

Please help me out how can i refer cell address in below VBA code to save file in desired destination in any folder.


Option Explicit

Sub create_and_email_pdf()
' Author - Philip Treacy :: http://www.linkedin.com/in/philiptreacy
' http://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook
Application.ScreenUpdating = False
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""

' *****************************************************
' ***** You Can Change These Variables *********

EmailSubject = ActiveSheet.Range("AA3")
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work
Email_To = ActiveSheet.Range("AA2")
Email_CC = ""
Email_BCC = ""

' ******************************************************

'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = True Then

DestFolder = .SelectedItems(1)

Else

MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"

Exit Sub

End If

End With

'Current month/year stored in H6 (this is a merged cell)
CurrentMonth = ActiveSheet.Range("AA7")

'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"

'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then

If AlwaysOverwritePDF = False Then

OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")

On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then

Kill PDFFile

Else

MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"

Exit Sub

End If

Else

On Error Resume Next
Kill PDFFile

End If

If Err.Number <> 0 Then

MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"

Exit Sub

End If

End If


'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating

'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

'Display email and specify To, Subject, etc
With OutlookMail

.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject
.attachments.Add PDFFile

If DisplayEmail = False Then

.Send

End If

End With


End Sub