PDF插件 for VBA 合并,提取,旋转等

opiona

bspboy 发表于 2024-8-20 15:36
大神，网盘的下载链接失效了，麻烦更新，想试试，适用就注册

补充内容 (2024-4-2 22:59):
插件有效期到 2024-12-31

链接：https://pan.baidu.com/s/1YkTGpI3uwOJsJgrEsKI3OA?pwd=5553
提取码：5553

wf。

膜拜大佬，真的太感谢了，这个我找了好久

opiona

有效期到: 2025-05-31

链接: https://pan.baidu.com/s/13zUYl82CZ8_860CysficKQ?pwd=wme1
提取码: wme1
复制这段内容后打开百度网盘手机App，操作更方便哦

opiona

纯VBA代码_拆分PDF文件_QQ14885553.zip (931.13 KB, 下载次数: 39)

2025-1-5 14:03 上传

点击文件名下载附件

1. 
   
2. 
   
3. Rem 测试代码
   
4. Sub Test()
   
5.     Call ExtractPDFpages(StrPDFfile:=ThisWorkbook.Path & "\A.PDF", StrOutFolder:=ThisWorkbook.Path & "\A", StrFG:="_P")
   
6.     Rem 提取d:\Guide.PDF，并保存为：d:\output\Guide-p1.PDF、d:\output\Guide-p2.PDF、d:\output\Guide-p3.PDF……
   
7. End Sub
   
8. 
   
9. Sub ExtractPDFpages(ByVal StrPDFfile As String, Optional ByVal StrOutFolder As String = "", Optional ByVal StrFG As String = "_P")
   
10.     Rem 函数：ExtractPDFpages  调用Acrobat提取PDF的单个页面并输出到指定目录(命名规则为[原文件名 - p#.PDF])
    
11.     Rem 参数: StrPDFfile       原始PDF文件的完整路径
    
12.     Rem 参数: StrOutFolder     提出的PDF页面的保存目录, 空白则=本身所在文件夹
    
13.     Rem 参数: StrFG            重命名的前缀 空白则=[_P]
    
14.     Rem 方法: Call ExtractPDFpages(StrPDFfile:=ThisWorkbook.Path & "\A.PDF", StrOutFolder:=ThisWorkbook.Path & "\A", StrFG:="_P")
    
15.     Rem 注意：需要在装有【Acrobat Professional】专业版软件的电脑上运行
    
16. 
    
17.     Dim PDF, PDFSource, FSO
    
18.     Dim iPageCount As Integer
    
19.     Dim sFileName As String
    
20. 
    
21.     Rem 原始PDF文件名,去掉文件夹名
    
22.     sFileName = Mid(StrPDFfile, InStrRev(StrPDFfile, "") + 1)
    
23.     sFileName = Left(sFileName, InStrRev(sFileName, ".") - 1)
    
24. 
    
25.     Rem 用Acrobat打开
    
26.     Set PDF = CreateObject("AcroExch.PDDoc")
    
27.     Set PDFSource = CreateObject("AcroExch.PDDoc")
    
28.     PDFSource.Open StrPDFfile
    
29.     iPageCount = PDFSource.GetNumPages   '//获得总页数
    
30. 
    
31.     Rem 输出用的文件夹名
    
32.     If StrOutFolder = "" Then
    
33.         StrOutFolder = Mid(StrPDFfile, 1, InStrRev(StrPDFfile, ""))
    
34.     End If
    
35.     If Right(StrOutFolder, 1) <> "" Then
    
36.         StrOutFolder = StrOutFolder & ""
    
37.     End If
    
38. 
    
39.     Rem 创建文件夹
    
40.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
41.     If FSO.FolderExists(StrOutFolder) = False Then
    
42.         MkDir StrOutFolder     '//创建文件夹
    
43.     End If
    
44. 
    
45.     Rem 每一页单独保存
    
46.     For I = 0 To iPageCount - 1
    
47.         PDF.Create   '//新建一个页面
    
48.         PDF.InsertPages -1, PDFSource, I, 1, 0   '//将指定页面放入空白页面
    
49.         Rem 另存为
    
50.         PDF.Save 1, StrOutFolder & sFileName & StrFG & Format(I + 1, "0000") & ".PDF"
    
51.         PDF.Close
    
52. 
    
53.     Next
    
54.     Rem 关闭Acrobat
    
55.     PDFSource.Close
    
56.     Set PDF = Nothing
    
57.     Set PDFSource = Nothing
    
58.    
    
59. End Sub
    
60. 
    
61. 
    
62. 
    
63. 
    

复制代码

逍遥爱迪生

好强大，不错好强大，不错

1013182120

牛，支持楼主，下载试用，

everbest2015

  Set PDF = CreateObject("AcroExch.PDDoc")  提示不支持此接口 电脑上是adobe acrobat reader

opiona

everbest2015 发表于 2025-1-20 09:22
Set PDF = CreateObject("AcroExch.PDDoc")  提示不支持此接口 电脑上是adobe acrobat reader

安装专业版试试

everbest2015

opiona 发表于 2025-1-20 17:53
安装专业版试试

好的大佬

mx23372

怎么过期了，大佬