PDA

View Full Version : Automatic Filename from cell info



whirlwind147
11-16-2011, 06:02 AM
Hi,

I have pieced together the code at the foot of this post from Ron de Bruin's site (most helpful!) but I have one last thing to do. What do I need to do to this code to make the filename automatically created and to stop the save as box coming up? What I would like to happen is for the filename to be called whatever is in cell AI809 with the word quotation at the end. I don't need to keep the file afterwards either - it can be killed but I don't know how to do this either!

Here is the code:


Option Explicit

'The code below are used by the macros in the other two modules
'Do not change the code in the functions in this module

Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant

'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")

'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If

'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If

'Now the file name is correct we Publish to PDF
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0

'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End If
End Function



Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
StrSubject As String, StrBody As String, Send As Boolean)
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = StrTo
.CC = ""
.BCC = ""
.Subject = StrSubject
.Body = StrBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Function

Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim FileName As String

If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected," & vbNewLine & _
"ungroup the sheets and try the macro again"
Else

FileName = RDB_Create_PDF(Range("AG802:AR870"), "", True, False)

If FileName <> "" Then
RDB_Mail_PDF_Outlook FileName, Range("AI809").Value, Range("AN806").Value & " Quotation", _
vbNewLine & Range("A817").Value & vbNewLine & _
Range("A818").Value, False

Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You cancelled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
End Sub

whirlwind147
11-17-2011, 02:37 AM
Is anyone able to help at all with this?

monarchd
11-17-2011, 12:18 PM
I got this to work, see if it's what you are trying to do:



Option Explicit
'The code below are used by the macros in the other two modules
'Do not change the code in the functions in this module

Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
Dim ck As Boolean
Dim TempFilePath
Dim str1
'Save the new workbook at this file path location
TempFilePath = "C:\"
'Test If the Microsoft Add-in is installed
'If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
'& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"

Application.DisplayAlerts = False 'DISABLE ALERT PROMPT
'pre fill the name of the file
str1 = Range("AI809").Value & "-Quotation"
ck = Application.Dialogs(xlDialogSaveAs).Show(str1)
If ck = True Then
Fname = Application.GetSaveAsFilename(str1, filefilter:=FileFormatstr, _
Title:="Create PDF")
End If
Application.DisplayAlerts = True 'RESETS DISPLAY ALERTS

'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If

'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If

'Now the file name is correct we Publish to PDF
On Error Resume Next
Myvar.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0

'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
'End If
End Function



Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
StrSubject As String, StrBody As String, Send As Boolean)
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = StrTo
.CC = ""
.BCC = ""
.Subject = StrSubject
.Body = StrBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Function

Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim FileName As String

If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected," & vbNewLine & _
"ungroup the sheets and try the macro again"
Else

FileName = RDB_Create_PDF(Range("AG802:AR870"), "", True, False)

If FileName <> "" Then
RDB_Mail_PDF_Outlook FileName, Range("AI809").Value, Range("AN806").Value & " Quotation", _
vbNewLine & Range("A817").Value & vbNewLine & _
Range("A818").Value, False

Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You cancelled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
End Sub

monarchd
11-17-2011, 12:20 PM
Whoops, I didn't have the add in, so I commented out these lines, you'll want to UNcomment:



'If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
'& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then




'End If
End Function