Microsoft Office Forums - View Single Post

gmayor · 04-02-2015, 11:33 PM

The following will save the current page as PDF on the desktop with a name you enter in a dialog box. However it won't work in Word 2003 which has no PDF function.

If your message header is correct in that you have Word 2003, you are going to need a PDF application that is programmable from VBA, such as Acrobat or PDFCreator. The following code will not work with either of those.

Code:

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