Word 宏：導出高質量 PDF（帶圖像）

Question

我將圖像導入 Word 文件，然后使用以下代碼將所有內容導出/保存為 PDF 文件：

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

問題是：雖然新導入的圖像在 Word 中的圖像質量很好，但在 PDF 文件中卻很糟糕（使用 Acrobat Reader 打開它）。

例如。 此圖像為 400%：

我也試過這個，但沒有改變：

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

Word 的“高級” 設置中的“不壓縮文件中的圖像”已打勾，但圖像最終仍會被壓縮。

如何在宏中創建具有適當圖像質量的 pdf 文件？

Answer 1

我發現生成具有良好圖像質量的 pdf 文件的唯一方法是使用 pdf 打印機，因為“另存為 pdf”似乎總是壓縮圖像。 Win 10 有一個內置的打印機（“Microsoft Print to PDF”），在 Win 7 中你需要額外安裝一個，我不確定你是否可以用同樣的方式訪問所有東西（可能有是插件添加的更簡單的方法）。

當然，您可以使用以下方法對所有內容進行硬編碼：

' "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

...但如果打印機不存在，您將收到一條錯誤消息，因此獲取所有可用打印機的列表更安全，然后檢查它的硬編碼名稱。

使用 Access（ 單擊）這很容易，不幸的是 Word 的 VBA 無法訪問Printers或Printer ，這使一切變得更加復雜：

有它一個很好的解決方案在這里，但它會如果你使用的是舊版本的Word這32位唯一的工作。 Word 2019 默認為 64 位，這會引發錯誤消息，我還沒有設法讓該代碼在 64 位上運行（ 此處的建議未解決）。

相反，我現在使用這個版本來檢查已安裝打印機的注冊表，並且更容易更新以使用 64 位。

調用額外的模塊：

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

檢查適用於 32 位和 64 位的打印機的代碼（來源：單擊，由我更改）：

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