Sub 导出图片PDF() Dim sourceDoc As Document Dim tempDoc As Document Dim sourceRange As Range Dim saveFolder As String Dim pageNum As Long Dim total_pages As Long Dim exportPath As String Dim fileName As String Set sourceDoc = ActiveDocument Application.ScreenUpdating = False ' --- 1. 固定路径：桌面创建 "图片PDF" 文件夹 --- saveFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\图片PDF\" If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\" total_pages = sourceDoc.Range.Information(wdNumberOfPagesInDocument) ' --- 批量处理每一页 --- For pageNum = 1 To total_pages ' --- 2. 提取文件名（保留中间空格）--- Set sourceRange = GetPageRange(sourceDoc, pageNum) If sourceRange Is Nothing Then GoTo NextPage Dim rawText As String, extractedName As String rawText = sourceRange.Paragraphs(1).Range.text extractedName = "" Dim keywords As Variant: keywords = Array("教师", "同学", "同志") Dim kw As Variant, pos As Integer For Each kw In keywords pos = InStr(rawText, kw) If pos > 0 Then extractedName = Trim(Left(rawText, pos - 1)) extractedName = Replace(extractedName, Chr(13), "") extractedName = Replace(extractedName, Chr(7), "") Exit For End If Next kw fileName = IIf(Len(extractedName) > 0, CleanFileName(extractedName), "Page_" & Format(pageNum, "000")) ' --- 3. 复制当前页内容 --- sourceRange.Copy Dim t As Double: t = Timer Do While Timer < t + 0.3: DoEvents: Loop ' 等待剪贴板就绪 ' --- 4. 新建临时文档并粘贴为图片 --- Set tempDoc = Documents.Add With tempDoc.PageSetup .pageWidth = sourceDoc.PageSetup.pageWidth .pageHeight = sourceDoc.PageSetup.pageHeight .TopMargin = sourceDoc.PageSetup.TopMargin .BottomMargin = sourceDoc.PageSetup.BottomMargin .LeftMargin = sourceDoc.PageSetup.LeftMargin .RightMargin = sourceDoc.PageSetup.RightMargin End With tempDoc.Content.Delete ' 清空默认段落 ' 执行粘贴 On Error Resume Next tempDoc.Paragraphs(1).Range.PasteSpecial DataType:=wdPasteEnhancedMetafile On Error GoTo 0 ' 等待图形出现 t = Timer Do While Timer < t + 1 If tempDoc.Shapes.count > 0 Or tempDoc.InlineShapes.count > 0 Then Exit Do DoEvents Loop ' 【关键修正】只查找真正的图片对象 Dim targetShape As Object Set targetShape = Nothing Dim i As Integer ' 优先检查浮动图形（Shapes） For i = 1 To tempDoc.Shapes.count If tempDoc.Shapes(i).Type = msoPicture Or tempDoc.Shapes(i).Type = msoLinkedPicture Then Set targetShape = tempDoc.Shapes(i) Exit For End If Next i ' 若未找到，再检查内嵌图形（InlineShapes） If targetShape Is Nothing Then For i = 1 To tempDoc.InlineShapes.count If tempDoc.InlineShapes(i).Type = wdInlineShapePicture Or _ tempDoc.InlineShapes(i).Type = wdInlineShapeLinkedPicture Then Set targetShape = tempDoc.InlineShapes(i) Exit For End If Next i End If ' 如果仍无有效图片，跳过本页 If targetShape Is Nothing Then tempDoc.Close SaveChanges:=False GoTo NextPage End If ' --- 5. 铺满整个页面 --- Dim pageWidth As Single, pageHeight As Single '将页边距设置为0 tempDoc.PageSetup.LeftMargin = 0 tempDoc.PageSetup.RightMargin = 0 tempDoc.PageSetup.TopMargin = 0 tempDoc.PageSetup.BottomMargin = 0 pageWidth = tempDoc.PageSetup.pageWidth - tempDoc.PageSetup.LeftMargin - tempDoc.PageSetup.RightMargin pageHeight = tempDoc.PageSetup.pageHeight - tempDoc.PageSetup.TopMargin - tempDoc.PageSetup.BottomMargin ' 【现在安全操作】 targetShape.LockAspectRatio = msoFalse targetShape.Width = pageWidth targetShape.Height = pageHeight ' --- 6. 导出为 PDF --- exportPath = saveFolder & fileName & ".pdf" ' 防重名 Dim j As Integer: j = 1 Dim baseName As String: baseName = exportPath Do While Dir(exportPath) <> "" j = j + 1 exportPath = Left(baseName, Len(baseName) - 4) & "(" & j & ").pdf" Loop ' 执行导出 On Error Resume Next tempDoc.ExportAsFixedFormat _ OutputFileName:=exportPath, _ ExportFormat:=wdExportFormatPDF, _ OptimizeFor:=wdExportOptimizeForPrint, _ Range:=wdExportAllDocument, _ Item:=wdExportDocumentContent, _ IncludeDocProps:=True, _ KeepIRM:=True, _ CreateBookmarks:=wdExportCreateNoBookmarks, _ DocStructureTags:=True, _ BitmapMissingFonts:=True, _ UseISO19005_1:=False On Error GoTo 0 ' --- 7. 关闭临时文档（不保存 .docx）--- tempDoc.Close SaveChanges:=FalseNextPage: Next pageNum Application.ScreenUpdating = True MsgBox "批量导出完成！" & vbCrLf & "文件已保存至：" & vbCrLf & saveFolder, vbInformationEnd Sub' 辅助函数：获取指定页的 RangeFunction GetPageRange(doc As Document, pageNum As Long) As Range Dim r As Range Dim nextPageStart As Long Dim lastPageStart As Long ' 1. 参数验证 If doc Is Nothing Then Set GetPageRange = Nothing Exit Function End If If pageNum <= 0 Or pageNum > doc.ComputeStatistics(wdStatisticPages) Then Set GetPageRange = Nothing Exit Function End If ' 2. 获取当前页开始位置 On Error Resume Next Set r = doc.Range r.Start = doc.GoTo( _ What:=wdGoToPage, _ Which:=wdGoToAbsolute, _ count:=pageNum).Start ' 3. 获取结束位置（处理最后一页） If pageNum < doc.ComputeStatistics(wdStatisticPages) Then ' 不是最后一页，获取下一页开始位置 nextPageStart = doc.GoTo( _ What:=wdGoToPage, _ Which:=wdGoToAbsolute, _ count:=pageNum + 1).Start r.End = nextPageStart Else ' 最后一页，使用文档结尾 r.End = doc.Range.End End If On Error GoTo 0 ' 4. 验证范围有效性 If r.Start >= 0 And r.End >= r.Start Then Set GetPageRange = r Else Set GetPageRange = Nothing End IfEnd Function' 辅助函数：清理文件名中的非法字符（修正：不再使用"文档"作为默认名）Function CleanFileName(fn As String) As String Dim c As String: c = "\/:*?""<>|" Dim i As Integer For i = 1 To Len(c) fn = Replace(fn, Mid(c, i, 1), "") Next i fn = Trim(fn) CleanFileName = fnEnd Function
夜雨聆风
