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页数的更多相关文章

  1. PPT文档页数显示的增加和更新

    在PPT的右下角增加页数的显示能够帮助演讲者把握进度,所以会经常遇到需要把页数显示在右下角的情况,这次在制作ppt的时候也遇到了.因此在这里总结一下设置方法. 一.在右下角显示当前页数和总页数 1)获 ...

  2. c#获取word文件页数、字数

    引用命名空间:using Microsoft.Office.Interop.Word; //启动Word程序 Application myWordApp = new ApplicationClass( ...

  3. [Python Study Notes]批量将ppt转换为pdf v1.0

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ...

  4. 获取PDF页数

    下载pdfbox这个包,这俩个方法都可以: PDDocument doc = PDDocument.load("e://aa.pdf"); System.out.println(d ...

  5. iTextSharp之pdfRead(两个文件文本内容的比较,指定页数的pdf截取,水印的添加)

    using iTextSharp.text; using iTextSharp.text.pdf; using iTextSharp.text.pdf.parser; using System; us ...

  6. dotnet获取PDF文件的页数

    #region 获取PDF文件的页数 private int BytesLastIndexOf(Byte[] buffer, int length, string Search) { if (buff ...

  7. Atitit 计算word ppt文档的页数

    Atitit 计算word ppt文档的页数 http://localhost:8888/ http://git.oschina.net/attilax/ati_wordutil private vo ...

  8. [开发笔记]-C#获取pdf文档的页数

    [操作pdf文档]之C#判断pdf文档的页数: /// <summary> /// 获取pdf文档的页数 /// </summary> /// <param name=& ...

  9. 真正免费,不限页数的PDF转Word工具

    真正免费,不限页数的PDF转Word工具 我们知道PDF转Word工具非常多,但大部分都有各种限制,限大小,限页数,加水印等等. 这其中绝大部分其实并不能做到格式完全一样,遇到图片更是直接傻了. 我们 ...

随机推荐

  1. nginx: [emerg] BIO_new_file("/etc/nginx/ssl_key/server.crt") failed (SSL: error:02001002:syste

    Centos 7.5 nginx+web集群配置https报错 报错信息: [root@lb01 conf.d]# nginx -tnginx: [emerg] BIO_new_file(" ...

  2. SVM学习笔记3-问题转化

    在1中,我们的求解问题是:$min_{w,b}$ $\frac{1}{2}||w||^{2}$,使得$y^{(i)}(w^{T}x^{(i)}+b)\geq 1 ,1 \leq i \leq n$ 设 ...

  3. Delphi程序的主题(Theme)设置

    本文参考了 http://superlevin.ifengyuan.tw/delphi-change-vcl-style/ 在项目的工程文件中勾选主题,设置缺省主题为Windows 部分代码如下: u ...

  4. Windows 安装Java与配置环境变量

    window系统安装java 下载JDK 首先我们需要下载java开发工具包JDK,下载地址:http://www.oracle.com/technetwork/java/javase/downloa ...

  5. ThreadLocal 的机制与内存泄漏

    ThreadLocal笔记 如上图所示 每个Thread 都有一个map,里面存着Entry<Key,value>,而key是实现了WeakReference的ThreadLocal,如果 ...

  6. 未能加载文件或程序集“System.Web.WebPages.Razor, Version=2.0.0.0, Culture=neutral, PublicKe

    https://bbs.csdn.net/topics/392046946 电脑没安装mvc4,应该是,解决这个问题一上午了今天,然后装完了后就好了! https://www.microsoft.co ...

  7. jquery里面获取div区块的宽度与高度

    https://blog.csdn.net/ll641058431/article/details/52768825 获取宽度 $('div').width();     获取:区块的本身宽度 $(' ...

  8. git界面里面复制粘贴

    git界面里常用的粘贴方法: 1.Insert键或者Fn+Insert键 2.右键或者shift+右键 Paste 粘贴 3.还有一些设置可以用,在git面板中(或者右键),点击option选项 这里 ...

  9. 【Django】【二】模板

    1. Django-bootstrap3 guest>python -m pip install django-bootstrap3 [代码] settings.py ""& ...

  10. SNMOJ 31

    考虑将给入的$A$数组差分,得到差分数组$C$ 每一次操作相当于把差分数组的每一位${+1}$,其中一个位置上${-n+1}$. 我们可以直接算出要进行多少次操作:${T=\frac{\sum A[i ...