Specifying a folder destination

Can anyone please tell me how i can make thew following code automatically save the PDF file to a specific file folder so the only thing that appears is the blank outlook email with the attached PDF file instead of having to manually save it to a specific location before emailing it....

Option Explicit
 
Sub create_and_email_pdf()

 
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 = ""
 
' *****************************************************

 
    EmailSubject = "Invoice Attached for "
    OpenPDFAfterCreating = False
    AlwaysOverwritePDF = False
    DisplayEmail = True
    Email_To = ""
    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
 
    
    CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1)
     
    '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 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
    
 
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=OpenPDFAfterCreating
 
    '
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
         
 
    With OutlookMail
         
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject & CurrentMonth
        .Attachments.Add PDFFile
                 
        If DisplayEmail = False Then
             
            .Send
             
        End If
         
    End With
     
  
End Sub