20171024xlVBA批量获取PPT\WORD\PDF页数
Public Sub ModifyFileNames()
Dim FolderPath As String
Dim FileNames As Variant Dim dotPos As Long
Dim ExtName As String
Dim RealName As String
Dim NewFile() As String
ReDim NewFile(1 To 1) As String
Dim Index As Long Dim StartTime As Variant
Dim UsedTime As Variant
StartTime = VBA.Timer 'Set ppApp = CreateObject("Powerpoint.Application") With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.AllowMultiSelect = False
.Title = "请选取Excel工作簿所在文件夹"
If .Show = -1 Then
FolderPath = .SelectedItems(1)
Else
MsgBox "您没有选中任何文件夹,本次汇总中断!"
Exit Sub
End If
End With If Right(FolderPath, 1) <> Application.PathSeparator Then FolderPath = FolderPath & Application.PathSeparator FileNames = FsoGetFiles(FolderPath, "*PDF*|*DOC*|*PPT*")
Index = 0
For n = LBound(FileNames) To UBound(FileNames) Step 1
Debug.Print FileNames(n)
Index = Index + 1
ReDim Preserve NewFile(1 To Index)
FilePath = FileNames(n)
If UCase(FileNames(n)) Like "*.PDF" Then
'Debug.Print PdfPageCount(FilePath)
dotPos = InStrRev(FilePath, ".")
ExtName = Mid(FilePath, dotPos)
Debug.Print ExtName
RealName = Left(FilePath, dotPos - 1)
NewPath = RealName & "(" & PdfPageCount(FilePath) & ")页" & ExtName
On Error Resume Next
Kill NewPath
On Error GoTo 0
VBA.FileCopy FilePath, NewPath
NewFile(Index) = NewPath
On Error Resume Next
Kill FilePath
On Error GoTo 0
ElseIf UCase(FileNames(n)) Like "*.DOC*" Then
'Debug.Print WordPageCount(FilePath)
dotPos = InStrRev(FilePath, ".")
ExtName = Mid(FilePath, dotPos)
Debug.Print ExtName
RealName = Left(FilePath, dotPos - 1)
NewPath = RealName & "(" & GetFilePages(FilePath) & "页)" & ExtName
On Error Resume Next
Kill NewPath
On Error GoTo 0
VBA.FileCopy FilePath, NewPath
NewFile(Index) = NewPath
On Error Resume Next
Kill FilePath
On Error GoTo 0
ElseIf UCase(FileNames(n)) Like "*.PPT*" Then
'Debug.Print SlidePageCount(FilePath)
dotPos = InStrRev(FilePath, ".")
ExtName = Mid(FilePath, dotPos)
Debug.Print ExtName
RealName = Left(FilePath, dotPos - 1)
NewPath = RealName & "(" & GetFilePages(FilePath) & "页)" & ExtName
On Error Resume Next
Kill NewPath
On Error GoTo 0
VBA.FileCopy FilePath, NewPath
NewFile(Index) = NewPath
On Error Resume Next
Kill FilePath
On Error GoTo 0
End If
Next n UsedTime = VBA.Timer - StartTime
' Debug.Print "UsedTime :" & Format(UsedTime, "#0.0000 Seconds")
MsgBox "UsedTime :" & Format(UsedTime, "#0.0000 Seconds") End Sub
Private Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
Dim Arr() As String
Dim FSO As Object
Dim ThisFolder As Object
Dim OneFile As Object
Dim Pats As Variant ReDim Arr(1 To 1)
Arr(1) = "None"
Dim Index As Long
Dim p As Long
Index = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo ErrorExit
Set ThisFolder = FSO.getfolder(FolderPath)
If Err.Number <> 0 Then Exit Function If InStr(Pattern, "|") > 0 Then
Pats = Split(Pattern, "|")
Else
ReDim Pats(1 To 1) As String
Pats(1) = Pattern
End If For Each OneFile In ThisFolder.Files
For p = LBound(Pats) To UBound(Pats) If UCase(OneFile.Name) Like Pats(p) Then
If Len(ComplementPattern) > 0 Then
If Not UCase(OneFile.Name) Like ComplementPattern Then
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If
Else
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If Exit For
End If Next p
Next OneFile
ErrorExit:
FsoGetFiles = Arr
Erase Arr
Set FSO = Nothing
Set ThisFolder = Nothing
Set OneFile = Nothing
End Function
Private Function PdfPageCount(ByVal FilePath As String) As Long
Debug.Print FilePath
Dim OneMatch, mStr$
PdfPageCount = 0
With CreateObject("Scripting.FileSystemObject").OpenTextFile(FilePath)
mStr = .readall
.Close
End With
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.Pattern = "\/Count ([\d]+)"
If .TEST(mStr) Then
For Each OneMatch In .Execute(mStr)
If Val(OneMatch.submatches(0)) > PdfPageCount Then
PdfPageCount = Val(OneMatch.submatches(0))
End If
Next OneMatch
End If
End With
End Function
Function GetFilePages(ByVal FilePath As String) As Variant
Dim AttrNo As Long
Select Case True
Case UCase(FilePath) Like "*.DOC*"
AttrNo = 148
Case UCase(FilePath) Like "*.PPT*"
AttrNo = 149
End Select
'工程-引用 “microsoft shell controls and automation”
Dim myShell As Shell32.Shell
Dim myShellFolder As Shell32.Folder
Dim FileName As String, Pos As Long, ExtName As String
Set myShell = New Shell
Pos = InStrRev(FilePath, "\")
FileName = Left(FilePath, Pos - 1)
ExtName = Mid(FilePath, Pos + 1)
Set myShellFolder = myShell.Namespace(FileName)
If myShellFolder.GetDetailsOf(myShellFolder.Items.Item(ExtName), AttrNo) <> "" Then
GetFilePages = myShellFolder.GetDetailsOf(myShellFolder.Items.Item(ExtName), AttrNo)
Else
GetFilePages = 0
End If
Set myShell = Nothing
Set myShellFolder = Nothing
End Function
20171024xlVBA批量获取PPT\WORD\PDF页数的更多相关文章
- PPT文档页数显示的增加和更新
在PPT的右下角增加页数的显示能够帮助演讲者把握进度,所以会经常遇到需要把页数显示在右下角的情况,这次在制作ppt的时候也遇到了.因此在这里总结一下设置方法. 一.在右下角显示当前页数和总页数 1)获 ...
- c#获取word文件页数、字数
引用命名空间:using Microsoft.Office.Interop.Word; //启动Word程序 Application myWordApp = new ApplicationClass( ...
- [Python Study Notes]批量将ppt转换为pdf v1.0
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ...
- 获取PDF页数
下载pdfbox这个包,这俩个方法都可以: PDDocument doc = PDDocument.load("e://aa.pdf"); System.out.println(d ...
- iTextSharp之pdfRead(两个文件文本内容的比较,指定页数的pdf截取,水印的添加)
using iTextSharp.text; using iTextSharp.text.pdf; using iTextSharp.text.pdf.parser; using System; us ...
- dotnet获取PDF文件的页数
#region 获取PDF文件的页数 private int BytesLastIndexOf(Byte[] buffer, int length, string Search) { if (buff ...
- Atitit 计算word ppt文档的页数
Atitit 计算word ppt文档的页数 http://localhost:8888/ http://git.oschina.net/attilax/ati_wordutil private vo ...
- [开发笔记]-C#获取pdf文档的页数
[操作pdf文档]之C#判断pdf文档的页数: /// <summary> /// 获取pdf文档的页数 /// </summary> /// <param name=& ...
- 真正免费,不限页数的PDF转Word工具
真正免费,不限页数的PDF转Word工具 我们知道PDF转Word工具非常多,但大部分都有各种限制,限大小,限页数,加水印等等. 这其中绝大部分其实并不能做到格式完全一样,遇到图片更是直接傻了. 我们 ...
随机推荐
- CentOS7学习记录(工具使用篇)
一. 远程连接终端中文乱码:如xShell 检查当前系统语言:echo $LANG 查看系统安装语言包:locale ,如果包含zh_CN.UTF-8表示已经安装中文语言.如果没有中文包,使用命令 ...
- Android 系统(64)---Android中m、mm、mmm、mma、mmma的区别【转】
本文转载自:https://blog.csdn.net/zhangbijun1230/article/details/80196379 Android中m.mm.mmm.mma.mmma的区别 m ...
- 如何评价 React 实现的前端 UI 库 material-ui?
作者:知乎用户链接:https://www.zhihu.com/question/51040975/answer/208582603来源:知乎著作权归作者所有.商业转载请联系作者获得授权,非商业转载请 ...
- Docker 入门指南——Dockerfile 指令
COPY 复制文件 格式: COPY [--chown=<user>:<group>] <源路径>... <目标路径> 源路径可以是多个,甚至可以使通配 ...
- 【做题】CF196E. Opening Portals 排除无用边&最小生成树
题意:给出一个有\(n\)个结点,\(m\)条边的连通无向图,边有边权,等于经过这条边所需的时间.有\(k\)个点设有传送门.一开始,所有传送门关闭.你从\(1\)号点出发,每当你到达一个有传送门的点 ...
- 设计模式总结(转自CS-Notes)
转载地址:https://github.com/CyC2018/CS-Notes/blob/master/docs/notes/%E8%AE%BE%E8%AE%A1%E6%A8%A1%E5%BC%8F ...
- 怎么用mybatis
一般mybatis的用法.mapper-spring-boot-starter + PageHelper分页插件. 1,PageHelper分页插件 . https://blog.csdn.net/ ...
- Git stash 常用命令
参考: Git: How to look at the stash Git学习笔记05--git stash Git stash 常用命令 1.git stash: 保存当前的工作进度: 2.git ...
- 1.Jenkins 在windows下的安装与配置
1. 安装Jenkins 1.war包安装:启动Jenkins命令,打开cmd至Jenkins安装目录下,运行命令 java -jar jenkins.war 如果改变默认端口,则指定端口例如端口号1 ...
- 登陆ArcGIS Server Manager时一直显示”请稍后……”
登陆Server Manager时一直显示”请稍后……”新建完成ARcGIS ServerSite,设置用户名和密码.但是登陆时却发现一直处于等待状态,如下图: 更换为IE浏览器后发现,已经可以登陆并 ...