Word 宏：导出高质量 PDF（带图像）
Word Macro: Export high quality PDF (with images)
我将图像导入 Word 文件，然后使用此代码 export/save 将所有内容作为 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 中的 "Do not compress images in file" "Advanced" settings 已勾选，但图像最终仍会被压缩。
如何在宏中创建具有适当图像质量的 pdf 文件？
我发现生成具有良好图像质量的 pdf 文件的唯一方法是使用 pdf 打印机，因为 "saving as 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 无法访问 Printers 或 Printer，这使得一切都变得更加复杂复杂：
有一个很好的解决方案 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 没解决）。
相反，我现在使用 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 文件，然后使用此代码 export/save 将所有内容作为 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
"Do not compress images in file" "Advanced" settings 已勾选，但图像最终仍会被压缩。
如何在宏中创建具有适当图像质量的 pdf 文件？
我发现生成具有良好图像质量的 pdf 文件的唯一方法是使用 pdf 打印机，因为 "saving as 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 无法访问 Printers 或 Printer，这使得一切都变得更加复杂复杂：
有一个很好的解决方案 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 没解决）。
相反，我现在使用 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