使用 VBA 从 Excel 到 Word 到 PDF

如何解决使用 VBA 从 Excel 到 Word 到 PDF

背景： 在 StackOverflow 的帮助下，我成功地找到了一种使用 VBA 将特定内容（文本、表格和图表）从 Excel 复制到带有书签的 Word 模板的方法。在保存此文件时，我不想要 .docx 格式，而是想要将其导出为 .pdf。我尝试使用 ExportAsFixedFormat 和 ExportAsFixedFormat2 并能够成功导出。

问题： 这个 .pdf 文件上的内容被导出为图像（我猜）。我无法突出显示或复制文件中的文本。我做错了什么，我该如何解决？ （仅供参考，内容复制在 pdf 上设置为“允许”）

我目前正在使用 ActiveDocument.ExportAsFixedFormat2 SaveName,wdExportFormatPDF,wdExportOptimizeforPrint 并且也尝试过其他变量。

任何帮助将不胜感激。

代码：

Option Explicit

Sub ExportFile()

    Dim wrdApp As Word.Application
    Dim WrdDoc As Word.Document
    Dim WrdRng As Word.Range
    Dim WrdShp As Word.Inlineshape
    Dim SaveName As String
    
    Dim ChrObj As ChartObject
    
    Set wrdApp = New Word.Application
    'wrdApp.Visible = True
    'wrdApp.Activate
    
    With wrdApp
        
        .Documents.Add Environ("UserProfile") & "\Desktop\Template.dotx"
        
        
        With .Selection
        Range("XEX771").copy
            .GoTo What:=-1,Name:="Bookmark1"
            .PasteSpecial xlPasteValues
            .GoTo What:=-1,Name:="Bookmark2"
        Range("AG696",Range("AG696").End(xlDown).End(xlToRight)).copy
        Application.Wait Now() + #12:00:02 AM#
            .PasteExcelTable True,False,False
            .GoTo What:=-1,Name:="Bookmark3"
        Range("F26",Range("F26").End(xlDown).End(xlToRight)).copy
        Application.Wait Now() + #12:00:02 AM#
            .PasteExcelTable True,Name:="Bookmark4"
        Range("XEO5").copy
            .PasteSpecial xlPasteValues
            .GoTo What:=-1,Name:="Bookmark5"
        Range("K26",Range("K26").End(xlDown).End(xlToRight)).copy
        Application.Wait Now() + #12:00:02 AM#
            .PasteExcelTable True,False
        End With
    
    Set ChrObj = ActiveSheet.ChartObjects(1)
        ChrObj.Chart.ChartArea.copy
        
        Application.Wait Now() + #12:00:02 AM#
        
    .Selection.GoTo What:=-1,Name:="Bookmark6"
    .Selection.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine
    
    Set ChrObj = ActiveSheet.ChartObjects(2)
        ChrObj.Chart.ChartArea.copy
        
        Application.Wait Now() + #12:00:02 AM#
        
    .Selection.GoTo What:=-1,Name:="Bookmark7"
    .Selection.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine

    Set ChrObj = ActiveSheet.ChartObjects(3)
        ChrObj.Chart.ChartArea.copy
        
        Application.Wait Now() + #12:00:02 AM#
        
    .Selection.GoTo What:=-1,Name:="Bookmark8"
    .Selection.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine
   
SaveName = Environ("UserProfile") & "\Desktop\FileName.pdf"

    .ActiveDocument.ExportAsFixedFormat2 SaveName,wdExportOptimizeforPrint

    End With

wrdApp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit

Set wrdApp = nothing

End Sub

解决方法

使用 Selection 的效率非常低 - 这也可能有助于解释为什么您在代码中插入了如此多的延迟。您还有许多不必要的 .Goto 和复制/粘贴操作。试试：

Sub ExportFile()
Dim wrdApp As New Word.Application,WrdDoc As Word.Document
Dim WrdRng As Word.Range,WrdShp As Word.InlineShape
Dim xlSheet As Excel.Worksheet: Set xlSheet = ActiveSheet
With wrdApp
  .Visible = False
  Set WrdDoc = .Documents.Add(Environ("UserProfile") & "\Desktop\Template.dotx")
  With WrdDoc
    .Bookmarks("Bookmark1").Range.Text = xlSheet.Range("XEX771").Text
    xlSheet.Range("AG696",Range("AG696").End(xlDown).End(xlToRight)).Copy
    .Bookmarks("Bookmark2").Range.PasteExcelTable True,False,False
    xlSheet.Range("F26",Range("F26").End(xlDown).End(xlToRight)).Copy
    .Bookmarks("Bookmark3").Range.PasteExcelTable True,False
    .Bookmarks("Bookmark4").Range.Text = xlSheet.Range("XEO5").Text
    xlSheet.Range("K26",Range("K26").End(xlDown).End(xlToRight)).Copy
    .Bookmarks("Bookmark5").Range.PasteExcelTable True,False
    xlSheet.ChartObjects(1).Chart.ChartArea.Copy
    .Bookmarks("Bookmark6").Range.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine
    xlSheet.ChartObjects(2).Chart.ChartArea.Copy
    .Bookmarks("Bookmark7").Range.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine
    xlSheet.ChartObjects(3).Chart.ChartArea.Copy
    .Bookmarks("Bookmark8").Range.PasteSpecial DataType:=wdPasteMetafilePicture,Placement:=wdInLine
    .SaveAs FileName:=Environ("UserProfile") & "\Desktop\FileName.pdf",_
      FileFormat:=wdFormatPDF,AddToRecentFiles:=False
    .Close False
  End With
  .Quit
End With
Set WrdDoc = Nothing: Set wrdApp = Nothing: Set xlSheet = Nothing
End Sub

,

这是通过 MS Word 保存 PDF 文件时“可能未嵌入字体时的位图文本”选项的问题。我参考了 this 页面并添加了 BitmapMissingFonts:=False。解决了问题。

.ActiveDocument.ExportAsFixedFormat2 SaveName,wdExportFormatPDF,BitmapMissingFonts:=False

谢谢大家！