Option Explicit
Private Declare Function SHGetSpecialFolderLocation _
                         Lib "shell32" (ByVal hwnd As Long, _
                                        ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList _
                         Lib "shell32" Alias "SHGetPathFromIDListA" _
                             (ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Private Const CSIDL_DESKTOP = &H0
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Sub SavePageAsPDF()
Dim strPDFName As String
Dim orng As Range
    strPDFName = InputBox("Enter the name for the PDF")
    If strPDFName = "" Then GoTo lbl_Exit
    If LCase(Right(strPDFName, 4)) = ".pdf" Then
        strPDFName = SpecFolder(&H0) & "\" & strPDFName
    Else
        strPDFName = SpecFolder(&H0) & "\" & strPDFName & ".pdf"
    End If
    ActiveDocument.ExportAsFixedFormat OutputFilename:=strPDFName, _
                                       ExportFormat:=wdExportFormatPDF, _
                                       OpenAfterExport:=True, _
                                       OptimizeFor:=wdExportOptimizeForPrint, _
                                       Range:=wdExportCurrentPage, From:=1, to:=1, _
                                       Item:=wdExportDocumentContent, _
                                       IncludeDocProps:=True, _
                                       KeepIRM:=True, _
                                       CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                       DocStructureTags:=True, _
                                       BitmapMissingFonts:=True, _
                                       UseISO19005_1:=False
lbl_Exit:
    Exit Sub
End Sub

Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

    strPath = Space(MAX_PATH)
    lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
    If lngPidlFound = NOERROR Then
        lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
        If lngFolderFound Then
            SpecFolder = Left$(strPath, _
                               InStr(1, strPath, vbNullChar) - 1)
        End If
    End If
    CoTaskMemFree lngPidl
lbl_Exit:
    Exit Function
End Function