Office Script code to print to PDF

paste this code into a module ,
then select the cells to save,
then run: SaveBlock2Pdf() (put it on the QuickAccess toolbar)

Option Explicit

Sub SaveBlock2Pdf()
Dim vFile
      
      'set print area of data to save
 ActiveSheet.PageSetup.PrintArea = Selection.Address
 'ActiveSheet.PageSetup.PrintArea = "$B$22:$D$29"
    
vFile = UserPick1File()
If vFile = "" Then Exit Sub

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=vFile, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
   ' ActiveWindow.SmallScroll Down:=3
End Sub




Public Function UserPick1File(Optional pvPath)
Dim strTable As String
Dim strFilePath As String
Dim sDialogMsg As String, sDecr  As String, sExt As String
Const msoFileDialogViewList = 1
Const msoFileDialogSaveAs = 2
Const msoFileDialogFilePicker = 3

'getFilterTxt pvFilter, sDecr, sExt, sDialog
If IsMissing(pvPath) Then pvPath = getMyDocs()

''SetFileFilter pvFilter, sDecr, sExt, sDialogMsg

'Application.FileDialog(msoFileDialogSaveAs) =2     'SAVE AS
'Application.FileDialog(msoFileDialogFilePicker) =3  'file OPEN

With Application.FileDialog(msoFileDialogSaveAs)   'REFERENCE not needed now : Microsoft Office XX.0 Object Library
    .AllowMultiSelect = True
    .Title = sDialogMsg   ' "Locate a file to Import"
    .ButtonName = "Save As"
    
     Dim lFilterIndex As Long

      For lFilterIndex = 1 To .Filters.Count
        'Debug.Print lFilterIndex, .Filters(lFilterIndex).Description
        
              'get pdf format from type filter
           If InStr(.Filters(lFilterIndex).Description, "PDF") > 0 Then
               .FilterIndex = lFilterIndex
               Exit For
           End If
       Next
        
    .InitialFileName = pvPath
    .InitialView = msoFileDialogViewList    'msoFileDialogViewThumbnail

        If .Show = 0 Then
           'There is a problem
           Exit Function
        End If

    'Save the first file selected
    UserPick1File = Trim(.SelectedItems(1))
End With
End Function




Public Function getMyDocs()
Dim vDir, vUsr

On Error GoTo errDocs
vUsr = Environ("UserProfile")
vDir = vUsr & "\Documents\"
If Not DirExists(vDir) Then
    vDir = vUsr & "\My Documents\"
    'If Not DirExists(vDir) Then
    '   vDir = "c:\temp"
    '   MakeDir vDir
    'End If
End If
getMyDocs = vDir
Exit Function
errDocs:
MsgBox "Cannot find temp folder", vbInformation, "getMyDocs():" & Err
End Function



Public Function DirExists(ByVal pvDir) As Boolean
Dim fso
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
DirExists = fso.FolderExists(pvDir)
Set fso = Nothing
End Function