[Visual Basic] 纯文本查看 复制代码
Option Explicit
'========================================================
' Word 企业级 PDF → 高清图片 插入系统（最终稳定版）
'
' 功能：
' 1. 多选 PDF
' 2. 当前光标位置插入
' 3. Poppler 真300DPI渲染
' 4. 自动分页
' 5. 图片自动居中
' 6. 自动适应页面
' 7. 保持原始比例
' 8. 支持超大PDF
' 9. 自动等待转换完成
'10. 自动删除缓存
'11. 支持中文路径
'12. Office 32/64位兼容
'13. 超时保护
'14. 防止哈希溢出
'15. 防止空数组崩溃
'
'========================================================
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As LongPtr
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As LongPtr, _
lpExitCode As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" _
(ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As LongPtr)
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
#End If
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
'========================================================
' 主入口
'========================================================
Sub InsertPDF_AsImages_Poppler_Final()
Dim fd As FileDialog
Dim pdfFile As Variant
Dim popplerExe As String
Dim mainTempFolder As String
Dim rng As Range
Dim maxWidth As Single
Dim totalPages As Long
Dim startTime As Double
Dim fso As Object
'====================================================
' 修改为你的真实路径
'====================================================
popplerExe = "C:\Poppler\Library\bin\pdftoppm.exe"
'====================================================
' 检查 Poppler
'====================================================
If Dir(popplerExe) = "" Then
MsgBox _
"未找到 pdftoppm.exe：" & vbCrLf & _
popplerExe, _
vbCritical, _
"缺少 Poppler"
Exit Sub
End If
'====================================================
' 初始化
'====================================================
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
startTime = Timer
Set rng = Selection.Range
Set fso = CreateObject("Scripting.FileSystemObject")
'====================================================
' 页面宽度
'====================================================
With ActiveDocument.PageSetup
maxWidth = .PageWidth _
- .LeftMargin _
- .RightMargin
If maxWidth <= 0 Then
maxWidth = .PageWidth * 0.9
End If
End With
'====================================================
' 主缓存目录
'====================================================
mainTempFolder = _
Environ$("TEMP") & _
"\WordPDF_Poppler_" & _
Format(Now, "yyyymmdd_hhnnss") & "\"
If Not fso.FolderExists(mainTempFolder) Then
fso.CreateFolder mainTempFolder
End If
'====================================================
' 选择 PDF
'====================================================
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "选择 PDF 文件（可多选）"
.Filters.Clear
.Filters.Add "PDF 文件", "*.pdf"
.AllowMultiSelect = True
If .Show <> -1 Then GoTo CLEAN_EXIT
End With
totalPages = 0
'====================================================
' 遍历 PDF
'====================================================
For Each pdfFile In fd.SelectedItems
totalPages = totalPages + _
ProcessOnePDF( _
CStr(pdfFile), _
popplerExe, _
mainTempFolder, _
rng, _
maxWidth, _
fso)
Next
'====================================================
' 完成
'====================================================
Application.StatusBar = False
MsgBox _
"PDF 插入完成！" & vbCrLf & vbCrLf & _
"总页数：" & totalPages & vbCrLf & _
"耗时：" & _
Format(Timer - startTime, "0.0") & " 秒", _
vbInformation
CLEAN_EXIT:
On Error Resume Next
If fso.FolderExists(mainTempFolder) Then
fso.DeleteFolder mainTempFolder, True
End If
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll
Application.StatusBar = False
End Sub
'========================================================
' 处理单个 PDF
'========================================================
Private Function ProcessOnePDF( _
pdfPath As String, _
popplerExe As String, _
mainTempFolder As String, _
rng As Range, _
maxWidth As Single, _
fso As Object) As Long
Dim pdfName As String
Dim subFolder As String
Dim outputPrefix As String
Dim cmd As String
Dim processID As Long
Dim processHandle As LongPtr
Dim exitCode As Long
Dim waitStart As Double
Dim imgFiles As Variant
Dim imgCount As Long
Dim i As Long
Dim shp As inlineShape
On Error GoTo ERROR_HANDLER
'====================================================
' PDF名称
'====================================================
pdfName = CleanFileName( _
fso.GetBaseName(pdfPath))
pdfName = pdfName & "_" & _
GetShortHash(pdfPath)
'====================================================
' 独立子目录
'====================================================
subFolder = mainTempFolder & pdfName & "\"
If Not fso.FolderExists(subFolder) Then
fso.CreateFolder subFolder
End If
'====================================================
' 输出前缀
'====================================================
outputPrefix = subFolder & pdfName
'====================================================
' 状态栏
'====================================================
Application.StatusBar = _
"正在转换：" & pdfPath
DoEvents
'====================================================
' Poppler命令
'====================================================
cmd = Chr$(34) & popplerExe & Chr$(34) & _
" -png -r 300 " & _
Chr$(34) & pdfPath & Chr$(34) & " " & _
Chr$(34) & outputPrefix & Chr$(34)
'====================================================
' 执行
'====================================================
MsgBox cmd
processID = Shell(cmd, vbNormalFocus)
If processID = 0 Then
Err.Raise 1001, , "Shell 启动失败"
End If
processHandle = OpenProcess( _
PROCESS_QUERY_INFORMATION, _
False, _
processID)
If processHandle = 0 Then
Err.Raise 1002, , "无法获取进程句柄"
End If
'====================================================
' 等待转换完成
'====================================================
waitStart = Timer
Do
GetExitCodeProcess processHandle, exitCode
DoEvents
Sleep 200
If Timer - waitStart > 120 Then
CloseHandle processHandle
Err.Raise 1003, , _
"PDF 转换超时"
End If
Loop While exitCode = STILL_ACTIVE
CloseHandle processHandle
'====================================================
' 获取 PNG
'====================================================
imgFiles = CollectImagesByPrefix( _
subFolder, _
pdfName)
'====================================================
' 空数组保护
'====================================================
If Not IsArray(imgFiles) Then
Err.Raise 1004, , _
"未生成 PNG 文件"
End If
If UBound(imgFiles) < 0 Then
Err.Raise 1005, , _
"PNG 文件为空"
End If
imgCount = UBound(imgFiles) + 1
'====================================================
' 插入图片
'====================================================
For i = 0 To imgCount - 1
Application.StatusBar = _
"插入第 " & _
(i + 1) & "/" & _
imgCount & " 页"
DoEvents
'------------------------------------------------
' 自动分页
'------------------------------------------------
If i > 0 Then
rng.InsertBreak wdPageBreak
End If
rng.Collapse wdCollapseEnd
'------------------------------------------------
' 插入图片
'------------------------------------------------
Set shp = _
ActiveDocument.InlineShapes.AddPicture( _
fileName:=imgFiles(i), _
LinkToFile:=False, _
SaveWithDocument:=True, _
Range:=rng)
'------------------------------------------------
' 保持比例
'------------------------------------------------
With shp
.LockAspectRatio = msoTrue
If .Width > maxWidth Then
.Width = maxWidth
End If
End With
'------------------------------------------------
' 图片居中
'------------------------------------------------
With shp.Range.ParagraphFormat
.Alignment = wdAlignParagraphCenter
.SpaceBefore = 0
.SpaceAfter = 6
.LineSpacingRule = wdLineSpaceSingle
End With
rng.SetRange shp.Range.End, shp.Range.End
Next
ProcessOnePDF = imgCount
Exit Function
ERROR_HANDLER:
MsgBox _
"处理 PDF 失败：" & vbCrLf & vbCrLf & _
pdfPath & vbCrLf & vbCrLf & _
"错误：" & Err.Description, _
vbExclamation
ProcessOnePDF = 0
End Function
'========================================================
' 收集 PNG 文件
'========================================================
Private Function CollectImagesByPrefix( _
folderPath As String, _
prefix As String) As Variant
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim tempList() As String
Dim count As Long
Dim i As Long
Dim j As Long
Dim tmp As String
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folderPath) Then
Exit Function
End If
Set fld = fso.GetFolder(folderPath)
count = 0
'====================================================
' 收集 PNG
'====================================================
For Each file In fld.Files
If LCase(fso.GetExtensionName(file.Name)) = "png" Then
If InStr(file.Name, prefix) > 0 Then
ReDim Preserve tempList(count)
tempList(count) = file.path
count = count + 1
End If
End If
Next
If count = 0 Then
Exit Function
End If
'====================================================
' 排序
'====================================================
For i = LBound(tempList) To UBound(tempList) - 1
For j = i + 1 To UBound(tempList)
If tempList(i) > tempList(j) Then
tmp = tempList(i)
tempList(i) = tempList(j)
tempList(j) = tmp
End If
Next
Next
CollectImagesByPrefix = tempList
End Function
'========================================================
' 清理非法字符
'========================================================
Private Function CleanFileName( _
ByVal s As String) As String
Dim badChars As Variant
Dim i As Long
badChars = Array("\", "/", ":", "*", _
"?", """", "<", ">", "|")
For i = LBound(badChars) To UBound(badChars)
s = Replace$(s, badChars(i), "_")
Next
CleanFileName = s
End Function
'========================================================
' 安全短哈希（防溢出）
'========================================================
Private Function GetShortHash( _
ByVal path As String) As String
Dim i As Long
Dim hash As Double
hash = 0
For i = 1 To Len(path)
hash = hash + _
Asc(Mid$(path, i, 1)) * i
hash = hash Mod 1000000
Next
GetShortHash = _
Format$(CLng(hash), "000000")
End Function
发表于 2026-5-16 14:18
|
发表于 2026-5-17 10:15
