Word Macro: Export high quality PDF (with images)

I import images into a Word file and export/save everything as a PDF file afterwards using this code:

ActiveDocument.SaveAs _
    filename:=pdfpath, _
    FileFormat:=wdFormatPDF, _
    LockComments:=False, _
    Password:="", _
    AddToRecentFiles:=True, _
    WritePassword:="", _
    ReadOnlyRecommended:=False, _
    EmbedTrueTypeFonts:=False, _
    SaveNativePictureFormat:=False, _
    SaveFormsData:=False, _
    SaveAsAOCELetter:=False

The problem is: While the image quality of the freshly imported images is fine in Word, it's pretty bad in the PDF file (using Acrobat Reader to open it).

Eg. this image at 400%:

I also tried this but no change:

ActiveDocument.ExportAsFixedFormat _
    OutputFileName:=pdfpath, _
    ExportFormat:=wdExportFormatPDF, _
    OpenAfterExport:=False, _
    OptimizeFor:=wdExportOptimizeForPrint, _
    Range:=wdExportAllDocument, _
    From:=1, _
    To:=1, _
    Item:=wdExportDocumentContent, _
    IncludeDocProps:=False, _
    KeepIRM:=False, _
    CreateBookmarks:=wdExportCreateHeadingBookmarks, _
    DocStructureTags:=True, _
    BitmapMissingFonts:=False, _
    UseISO19005_1:=False

"Do not compress images in file" in Word's "Advanced" settings is ticked but the images still end up getting compressed.

How do I create a pdf file with proper image quality in a macro?

The only way of generating a pdf file with decent image quality I've found is to use a pdf printer, as "saving as pdf" always seems to compress images. Win 10 has a built in printer for that ("Microsoft Print to PDF"), with Win 7 you're going to need to install an extra one and I'm not sure if you can then access everything the same way (there might be an easier way added by the addon).

Of course you can hardcode everything with:

' "Application.ActivePrinter = " sets Word's default printer (not Windows'!), so save the old setting, then restore it in the end
Dim newPrinter as String
Dim oldPrinter as String
newPrinter = "Microsoft Print to PDF"
oldPrinter = Application.ActivePrinter
ActivePrinter = newPrinter
ActiveDocument.PrintOut OutputFileName:=filepathandname + ".pdf"
Application.ActivePrinter = oldPrinter

... but if the printer doesn't exist, you're going to get an error message, so it's safer to get a list of all available printers, then check it for the hardcoded name.

This is pretty easy with Access (click), unfortunately Word's VBA hasn't got access to Printers or Printer, which makes everything a bit more complicated:

There's a good solution for it here BUT it'll only work if you're using an old version of Word that's 32bit. Word 2019 is 64bit by default, which throws an error message and I haven't managed to get that code to run with 64bit yet (the suggestions here didn't fix it).

Instead I'm now using this version that checks the registry for installed printers and was easier to update to work with 64bit.

Calling the extra module:

Private Function PrinterExists() As Boolean
    Dim allprinters() As String
    Dim foundPrinterVar As Variant
    Dim foundPrinter As String
    Dim printerName As String

    printerName = "Microsoft Print to PDF"
    PrinterExists = False
    allprinters = GetPrinterFullNames()

    For Each foundPrinterVar In allprinters
        foundPrinter = CStr(foundPrinterVar) 'Convert Variant to String

        If foundPrinter = printerName Then
            PrinterExists = True
            Exit Function
        End If
    Next
End Function

Code to check for printers that works with both 32bit and 64bit (source: click, changes by me):

Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modListPrinters
' By Chip Pearson, chip@cpearson.com  www.cpearson.com
' Created 22-Sept-2012
' This provides a function named GetPrinterFullNames that
' returns a String array, each element of which is the name
' of a printer installed on the machine.
' Source: http://www.cpearson.com/excel/GetPrinters.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

#If VBA7 Then ' VBA7 for 64bit
    Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
        Alias "RegOpenKeyExA" ( _
        ByVal HKey As Long, _
        ByVal lpSubKey As String, _
        ByVal ulOptions As Long, _
        ByVal samDesired As Long, _
        phkResult As Long) As Long

    Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
        Alias "RegEnumValueA" ( _
        ByVal HKey As Long, _
        ByVal dwIndex As Long, _
        ByVal lpValueName As String, _
        lpcbValueName As Long, _
        ByVal lpReserved As Long, _
        lpType As Long, _
        lpData As Byte, _
        lpcbData As Long) As Long

    Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
        ByVal HKey As Long) As Long
#Else
    Private Declare Function RegOpenKeyEx Lib "advapi32" _
        Alias "RegOpenKeyExA" ( _
        ByVal HKey As Long, _
        ByVal lpSubKey As String, _
        ByVal ulOptions As Long, _
        ByVal samDesired As Long, _
        phkResult As Long) As Long

    Private Declare Function RegEnumValue Lib "advapi32.dll" _
        Alias "RegEnumValueA" ( _
        ByVal HKey As Long, _
        ByVal dwIndex As Long, _
        ByVal lpValueName As String, _
        lpcbValueName As Long, _
        ByVal lpReserved As Long, _
        lpType As Long, _
        lpData As Byte, _
        lpcbData As Long) As Long

    Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
        ByVal HKey As Long) As Long
#End If

Public Function GetPrinterFullNames() As String()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetPrinterFullNames
' By Chip Pearson, chip@cpearson.com, www.cpearson.com
' Returns an array of printer names, where each printer name
' is the device name followed by the port name. The value can
' be used to assign a printer to the ActivePrinter property of
' the Application object. Note that setting the ActivePrinter
' changes the default printer for Excel but does not change
' the Windows default printer.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long    ' index into Printers()
Dim HKey As Long    ' registry key handle
Dim Res As Long     ' result of API calls
Dim Ndx As Long     ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long    ' length of ValueName
Dim DataType As Long        ' registry value data type
Dim ValueValue() As Byte    ' byte array of registry value value
Dim ValueValueS As String   ' ValueValue converted to String
Dim CommaPos As Long        ' position of comma character in ValueValue
Dim ColonPos As Long        ' position of colon character in ValueValue
Dim M As Long               ' string index

' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)

' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
    KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
    ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
    M = InStr(1, ValueName, Chr(0))
    If M > 1 Then
        ' clean up the ValueName
        ValueName = Left(ValueName, M - 1)
    End If
    ' find position of a comma and colon in the port name
    CommaPos = InStr(1, ValueValue, ",")
    ColonPos = InStr(1, ValueValue, ":")
    ' ValueValue byte array to ValueValueS string
    On Error Resume Next
    ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
    On Error GoTo 0
    ' next slot in Printers
    PNdx = PNdx + 1
    ' Printers(PNdx) = ValueName & " on " & ValueValueS
    ' ^ This would return e.g. "Microsoft Print to PDF on Ne02:", I only want the actual name:
    Printers(PNdx) = ValueName

    ' reset some variables
    ValueName = String(255, Chr(0))
    ValueNameLen = 255
    ReDim ValueValue(0 To 999)
    ValueValueS = vbNullString
    ' tell RegEnumValue to get the next registry value
    Ndx = Ndx + 1
    ' get the next printer
    Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
        0&, DataType, ValueValue(0), 1000)
    ' test for error
    If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
        Exit Do
    End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function