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打开它）。

例如。 this图片占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的“高级” settings中选中了“请勿压缩文件中的图像”，但最终仍会压缩图像。

如何在宏中创建具有适当图像质量的pdf文件？

Answer 1

我发现生成具有良好图像质量的pdf文件的唯一方法是使用pdf打印机，因为“另存为pdf”似乎总是会压缩图像。 Win 10为此具有一个内置打印机（“ Microsoft打印为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无法访问Printers或Printer，这使一切变得更加复杂：

有一个很好的解决方案here，但只有在您使用32位的旧版Word时，它才能正常工作。 Word 2019默认情况下为64位，会引发错误消息，但我尚未设法使该代码以64位运行（建议here尚未解决该问题）。

相反，我现在使用的是this版本，该版本可以检查注册表中已安装的打印机，并且更易于更新以使用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位打印机的代码（来源：click，由我进行更改）：

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

Word宏：导出高质量的PDF（带图片）

1 个答案: