Word VBA：批量转PDF且保留书签

守候

兴趣，是学好一切的重要前提！

一、前提说明

1.讨论范围

这里只讨论 通过Word软件自带的方法 完成生成PDF时创建PDF标签的方法，外部插件不在探讨和研究范围

2.示例文档说明

示例文档里面有两处标题和一处书签。

二、Word自带转PDF方法

1.另存

点击【文件】-【另存为】，格式选【PDF】

可以看到在保存选项中，有 根据标题和Word书签创建书PDF签选项 的选项。

2.打印

点击【文件】-【打印】，选择虚拟打印机最好的微软自带的

可以看到，在【打印机属性】中是没有PDF标签的设置选项的

3.导出

（1）点击【文件】-【导出】-【创建PDF／XPS文档】

（2）点击上图右侧【创建PDF／XPS文档】，在弹出的导出按钮中，也有【选项】按钮，点击可以在对话框中设置导出PDF时的标签选项

综上测试与观察，得出结论：

手动方式中，可以通过另存和导出两种方式，完成 Word转PDF时根据Word标题或书签 创建PDF标签 的任务。

手动创建PDF的方式	能否根据Word标题或标签创建PDF书签
另存	是
打印	否
导出	是

三、VBA代码另存和导出和手动的差别

注：这里以另存激活文档（当前正打开的文档）为PDF举例

1.另存

另存至少需要写两个参数：文件名和格式

Sub 另存PDF_不能创建书签()
    ActiveDocument.SaveAs2 fileName:="E:\Zhuomian_CJ\Test01.PDF", fileFormat:=wdFormatPDF
End Sub

但是， Word VBA另存的方法中是没有创建PDF书签的参数 的，通过官方文档也可以证实：

此外，我们打开一个用上述这段代码另存的一个文件也可以再次证实上述结论：

至此，可以总结：

如果需 要用VBA批量操作，我们就只能通过【导出】的方式 达到生成PDF同时创建PDF书签的要求。

VBA创建PDF的方式	能否根据Word标题或标签创建PDF书签
另存	否
打印	否
导出	是

2.导出

（1）方法

我们可以通过【ExportAsFixedFormat】或者【ExportAsFixedFormat2】方法进行导出，二者的区别中此处可以不用管。

（2）参数

通过官方文档，可以看到所有参数

这里，前两个参数是导出的文件路径和文件格式，必须要写。

这里，剪头标记的参数【 CreateBookmarks 】，通过说明可以看到就是选择生成PDF时书签的参数。

具体怎么设置呢？点击紫色文字

继续看一下官方文档：

可以清楚看到，三类书签选项的枚举常量名称、值及其说明，此参数根据需要选择即可。

（3）示例代码

A.根据Word标题创建PDF书签

我们将文档导出到前面演示相同的位置，格式为PDF，书签参数选择上图中的第1种

Sub 导出PDF_根据Word标题创建书签()
    ActiveDocument.ExportAsFixedFormat2 outputfilename:="E:\Zhuomian_CJ\Test01.PDF", _
        ExportFormat:=wdExportFormatPDF, createBookMarks:=wdExportCreateHeadingBookmarks
End Sub

我们看看生成的PDF文件

可以看到，PDF中只有Word文档中两处标题对应的书签。

B.根据Word书签创建PDF书签

我们将文档导出到前面演示相同的位置，格式为PDF，书签参数选择上图中的第3种

Sub 导出PDF_根据Word书签创建书签()
    ActiveDocument.ExportAsFixedFormat2 outputfilename:="E:\Zhuomian_CJ\Test01.PDF", _
        ExportFormat:=wdExportFormatPDF, createBookMarks:=wdExportCreateWordBookmarks
End Sub

我们看到生成的PDF书签效果：

可以看到只有Word书签的内容，和官方说明文档完全一样，没有问题。

四、批量操作代码

1.示例代码

Rem 这里是主程序，会对主文件夹及其各级文件夹下所有Word文件执行导出操作
    '可以先把要操作的文件整理有一个文件夹下，以免有多余文件导出
Sub 批量导出PDF主程序()
    Dim fd As FileDialog
    Dim fso As Object
    Dim arr() '存储每次遍历到的文件夹的子文件夹
    Dim brr() '临时存储每次遍历到的文件夹的子文件夹
    Dim crr() '存储所有文件夹
    Dim drr() '存储所有Word文件路径
    Dim myFolder As Object
    Dim subFolder As Variant
    Dim i As Long
    Dim j As Long
    Dim m As Long
    Dim myFile As Object
    Dim 后缀 As String
    Dim t0 As Single
    Dim 书签类型 As Long
    t0 = Timer
    i = 0: j = 0: m = 0
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fd
        .Title = "选择主文件夹"
        If .Show Then
            i = i + 1
            ReDim Preserve crr(1 To i)
            crr(i) = .SelectedItems(1)
            arr = crr
            书签类型 = CLng(Trim(InputBox("请输入书签类型：" & vbCrLf & "0--不创建书签" _
                & vbCrLf & "1--根据Word标题创建书签" & vbCrLf & "2--根据Word书签创建书签", "书签类型", 1)))
            Do While Not InStr("012", CStr(书签类型)) > 0
                Select Case MsgBox("输入不符合要求，请：" & vbCrLf & "重新输入（是）" & vbCrLf & "退出程序（否）：", vbInformation + vbYesNo, "错误提示")
                    Case vbYes
                        书签类型 = CLng(Trim(InputBox("请输入书签类型：" & vbCrLf & "0--不创建书签" _
                            & vbCrLf & "1--根据Word标题创建书签" & vbCrLf & "2--根据Word书签创建书签", "书签类型", 1)))
                    Case vbNo
                        Exit Sub
                End Select
            On Error Resume Next
            Do While Err.Number = 0
                For j = LBound(arr) To UBound(arr)
                    Set myFolder = fso.GetFolder(arr(j))
                    If myFolder.subFolders.Count > 0 Then
                        For Each subFolder In myFolder.subFolders
                            i = i + 1
                            ReDim Preserve crr(1 To i)
                            crr(i) = subFolder.Path
                            m = m + 1
                            ReDim Preserve brr(1 To m)
                            brr(m) = subFolder.Path
                    End If
                m = 0
                arr = brr
                Erase brr
            On Error GoTo 0
            i = 0
            For j = LBound(crr) To UBound(crr)
'                Debug.Print j, crr(j)
                Set myFolder = fso.GetFolder(crr(j))
                For Each myFile In myFolder.Files
                    后缀 = fso.GetExtensionName(myFile.Path)
                    If 后缀 Like "doc*" And Not 后缀 Like "*~$*" Then
                        i = i + 1
                        ReDim Preserve drr(1 To i)
                        drr(i) = myFile.Path
                    End If
            For j = LBound(drr) To UBound(drr)
                Rem 此处以下为调用的处理过程
                Application.ScreenUpdating = False
                Call 导出PDF_创建书签(drr(j), 书签类型)
                Application.ScreenUpdating = True
                Rem 此处以上为调用的处理过程
                Debug.Print Format(j, String(Len(CStr(UBound(drr))), "0")), drr(j), "导出完成"
        End If
    End With
    Set fd = Nothing
    Set fso = Nothing
    Set myFolder = Nothing
    On Error Resume Next
    Debug.Print "完成   共导出" & UBound(drr) & "个文件为PDF   用时" & Timer - t0 & "秒"
End Sub
Sub 导出PDF_创建书签(文件名, 书签类型 As Long)
    Dim aDoc As Document
    Dim fso As Object
    Dim 文件名1 As String
    Set aDoc = Documents.Open(文件名)
    Set fso = CreateObject("Scripting.FileSystemObject")
    文件名1 = fso.GetBaseName(文件名)
    aDoc.ExportAsFixedFormat2 outputfilename:=aDoc.Path & "\" & 文件名1 & ".PDF", _
        ExportFormat:=wdExportFormatPDF, CreateBookMarks:=书签类型