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
