Sub BatchConvertDocToPDF()
Dim sourceFolder As String
Dim targetFolder As String
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim doc As Document
Dim fileCount As Integer
Dim successCount As Integer
Dim pdfPath As String
' 初始化文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")
' 选择源文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择包含Word文档的文件夹"
If .Show <> -1 Then Exit Sub
sourceFolder = .SelectedItems(1)
End With
' 创建目标文件夹
targetFolder = sourceFolder & "\PDF输出\"
If Not fso.FolderExists(targetFolder) Then
fso.CreateFolder targetFolder
End If
' 获取文件总数
fileCount = fso.GetFolder(sourceFolder).Files.Count
successCount = 0
' 设置进度条
Application.StatusBar = "准备开始转换..."
DoEvents
' 遍历文件夹
For Each file In fso.GetFolder(sourceFolder).Files
If LCase(fso.GetExtensionName(file.Name)) Like "doc*" Then
On Error Resume Next ' 启用错误捕获
' 打开文档
Set doc = Documents.Open(file.Path, ReadOnly:=True, Visible:=False)
' 构建PDF路径
pdfPath = targetFolder & fso.GetBaseName(file.Name) & ".pdf"
' 转换设置（关键修正点）
With doc
.ExportAsFixedFormat _
OutputFileName:=pdfPath, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
CreateBookmarks:=wdExportCreateHeadingBookmarks
' 更新进度
successCount = successCount + 1
Application.StatusBar = "正在转换：" & file.Name & _
" (" & successCount & "/" & fileCount & ")"
.Close SaveChanges:=False
End With
' 错误处理
If Err.Number <> 0 Then
MsgBox "转换失败：" & file.Name & vbCrLf & _
"错误号：" & Err.Number & vbCrLf & _
"错误描述：" & Err.Description, vbExclamation
Err.Clear
End If
Set doc = Nothing
DoEvents
End If
Next file
' 清理和反馈
Application.StatusBar = False
MsgBox "转换完成！" & vbCrLf & _
"成功转换：" & successCount & "个文件" & vbCrLf & _
"输出位置：" & targetFolder, vbInformation
End Sub