Change VBA to store PDF file in same folder are the Excel Workbook.

[kshines]

Wise people of the forum. I found this great code in the forum. It works perfect but I would like it to store the newly created PDF file in the same folder as the Excel workbook is in.
Any help would be educational and helpful.
Thanks
KH

Sub Email_PDF_rhouston08()



Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
Dim Email As String
Dim Subject As String
Dim Content As String


With Application
.ScreenUpdating = False
.EnableEvents = False
End With

' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.

TempFilePath = Environ$("temp") & "\"



TempFileName = Range("s10").Value & ".pdf"

'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
Email = Range("a1").Value
Subject = Range("c12").Value
Content = Range("a7").Value

'Now Export the Activesshet as PDF with the given File Name and path

On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With

'Now open a new mail
Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)

On Error Resume Next
With NewMail
.To = Email
.Subject = Subject
.body = Content
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.display 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0

'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder

Kill FileFullPath

'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing

'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Kindly Check The Contents")
'Call Dir_Macro
Exit Sub
err:
MsgBox err.Description


End Sub


Sub Directory()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Range("s10").Value ' New directory name


strFilename = Range("C:\Users\kellyh\Desktop\Test Program").Value 'New file name
strDefpath = "C:\Users\kellyh\Desktop\Test Program" 'kindly Change the Path To your Requirements
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub


MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string
ActiveWorkbook.SaveAs FileName:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Call PDF
End Sub


Sub PDF()
Dim SaveAsStr As String


SaveAsStr = ActiveWorkbook.Path & "\" & ActiveSheet.Range("A4").Value


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=SaveAsStr & ".pdf", _
OpenAfterPublish:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

 

[Biz]

Hi,

I believe you need to modify only PDF code only item in green.
Does it help?

Sub PDF()
    Dim SaveAsStr As String


    SaveAsStr = [COLOR=rgb(65, 168, 95)]ThisWorkbook.Path[/COLOR] & "\" & ActiveSheet.Range("A4").Value


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=SaveAsStr & ".pdf", _
        OpenAfterPublish:=False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
 End Sub

Biz

 

[Peter_SSs]

@Biz
If you want to apply your own formatting to vba code you need to use the rich tags not the vba tags

@kshines
When posting vba code, please use code tags. See my signature block below for more details. Reading & debugging code that is all left aligned is very difficult.

I also suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version.