Convert excel worksheet to PDF?|VBA & Macros|Excel Forum|My Online Training Hub

Hello,

My name is Miguel

I use the following procedures to convert my excel sheets to PDF,

I hope i can help

Private Sub Excel_ExportPDF()

Dim CurrentFolder As String
Dim FileName As String
Dim UniqueName As Boolean
Dim UserAnswer As VbMsgBoxResult
Dim DirFile As String

UniqueName = False

If FolderFilePDF = "Error" Then ' folder exist ?
     MsgBox "Access denied:" & Chr(10) & Chr(10) & "• Unable to locate or create destination folder!", vbCritical, "Critical error"
     Exit Sub
End If

CurrentFolder = FolderFilePDF & "\"
'FileName = "PDF file name"
FileName = Me.TextBox2.Text

Do While UniqueName = False ' File Already Exist?
     DirFile = CurrentFolder & FileName & ".pdf"
          If Len(Dir(DirFile)) <> 0 Then
               UserAnswer = MsgBox("A PDF file with that name was found:" & Chr(10) & Chr(10) & "• Do you want to replace it with this new one?.", vbQuestion + vbYesNoCancel, "Attention ")
               If CStr(UserAnswer) = CStr(False) Then Exit Sub
               If UserAnswer = vbCancel Then Exit Sub
               If UserAnswer = vbYes Then
                    UniqueName = True
                         ElseIf UserAnswer = vbNo Then
ReTry:
                         Do
                              FileName = Application.InputBox("Select new name to save the file", "Add new name to save the file", FileName, , , , , Type:=2)
                              If FileName = "" Then
                                   UniqueName = False
                                   MsgBox "Error:" & Chr(10) & Chr(10) & "• The name is invalid! No data was entered in the text box!", vbCritical, "An error has occurred"
                                   GoTo ReTry:
                              End If
                              If FileName Like "*[[/*\?!#$%&(),;:.=]*" Or FileName Like "*[]]*" Then 'do not allow invalid characters
                                   UniqueName = False
                                   MsgBox "Error:" & Chr(10) & Chr(10) & "• The name is invalid! Forbidden characters!", vbCritical, "An error has occurred"
                                   GoTo ReTry:
                              End If
                              If CStr(FileName) = CStr(False) Then Exit Sub
                         Loop While ValidFileName(FileName) = False
                              If ValidFileName(FileName) Then
                                   UniqueName = True
                                   GoTo nextStep:
                              End If
               End If
                    Else
                         UniqueName = True
          End If
Loop

nextStep:
On Error GoTo ProblemSaving:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=CurrentFolder & FileName & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0

ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Select

MsgBox "PDF file successfully created and saved in: " & Chr(10) & Chr(10) & "• " & CurrentFolder & Chr(10) & Chr(10) & "With the following name: " & Chr(10) & Chr(10) & "• " & FileName, vbInformation, "Successful conversion"

Exit Sub

ProblemSaving:
     MsgBox "Access denied:" & Chr(10) & Chr(10) & "• Existing PDF file open, close it and try again!", vbCritical, "Critical error"
Exit Sub

End Sub

Public Function ValidFileName(FileName As String) As Boolean ' determine if PDF file name already Exists

Dim CurrentFolder As String
Dim DirFile As String

CurrentFolder = FolderFilePDF & "\"

ValidFileName = False
'On Error GoTo InvalidFileName
DirFile = CurrentFolder & FileName & ".pdf"

If Len(Dir(DirFile)) <> 0 Then
     ValidFileName = False
          Else
               ValidFileName = True
End If

Exit Function
'InvalidFileName:
' ValidFileName = False
End Function

Public Function FolderFilePDF() As String ' determine if folder exists ? if not create one if is possible

Dim WshShell As Object
Dim fso As Object
Dim SpecialPath As String

Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("scripting.filesystemobject")

'SpecialPath = ThisWorkbook.path & Application.PathSeparator & "BackupPDF"
SpecialPath = ThisWorkbook.path

If Right(SpecialPath, 1) <> "\" Then
     SpecialPath = SpecialPath & "\"
End If

If fso.FolderExists(SpecialPath & "BackupPDF") = False Then
     On Error Resume Next
     MkDir SpecialPath & "BackupPDF"
     On Error GoTo 0
End If

If fso.FolderExists(SpecialPath & "BackupPDF") = True Then
     FolderFilePDF = SpecialPath & "BackupPDF"
          Else
               FolderFilePDF = "Error"
End If

End Function