时间戳

首页 > 解决方案 > Word 宏：导出高质量 PDF（带图像）

vba - Word 宏：导出高质量 PDF（带图像）

问题描述

我将图像导入 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 文件？

标签： vbapdfms-wordimage-quality

解决方案

我发现生成具有良好图像质量的 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 ( click )这很容易，不幸的是 Word 的 VBA 无法访问Printersor Printer，这使一切变得更加复杂：

这里有一个很好的解决方案，但它只有在您使用的是 32 位的旧版 Word 时才有效。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

推荐阅读