按标题批量重命名word文档和excel文件

很多网友下载了大量的word文档，发现文件名都是日期或者字母，无法从文件名看出文档的内容，也不方便管理。
特奉献安装标题批量重命名word的代码：


word版：

Option Explicit
Dim arrFiles()
Dim cntFiles%

Sub Main()
Dim i%, StartFolder$, SavePath$
Dim fso As New FileSystemObject, fd As Folder
ReDim arrFiles(1 To 1000)
cntFiles = 0
StartFolder = "D:\Word" '原文件目录
SavePath = "D:\Word2" '改名后的文件目录
Set fd = fso.GetFolder(StartFolder)
SearchFiles fd
ReDim Preserve arrFiles(1 To cntFiles)
For i = 1 To cntFiles
RenameDocument arrFiles(i), SavePath, i
Next i
End Sub

Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
If LCase(Right(fl.Path, 4)) = ".doc" Then
cntFiles = cntFiles + 1
If cntFiles >= UBound(arrFiles) Then ReDim Preserve arrFiles(1 To cntFiles + 1000)
arrFiles(cntFiles) = fl.Path
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub

Sub RenameDocument(ByVal wordFileName, ByVal wordFilePath, ByVal num)
On Error Resume Next
Dim myTitle$, myFileName$
Dim mydoc As Document, myRange As Range
Set mydoc = Word.Documents.Add
mydoc.Activate
Selection.InsertFile fileName:=wordFileName, Range:="", ConfirmConversions:= _
False, Link:=False, Attachment:=False
ActiveWindow.View.Type = wdPageView
Set myRange = mydoc.Paragraphs.First.Range
myRange.SetRange myRange.Start, myRange.End - 1
myTitle = Trim(myRange.Text)
If (myTitle = "") Or (Len(myTitle) > 50) Then
Debug.Print "ERR:--------------------------------------------" + wordFileName
Shell "cmd.exe /c echo " & "ERR:--------------------------------------------" & wordFileName & ">>D:\Word.log"
mydoc.Close SaveChanges:=wdDoNotSaveChanges
SendKeys ("{ESC}")
Exit Sub
End If
myFileName = wordFilePath + "\" + myTitle + ".doc"
mydoc.SaveAs myFileName
mydoc.Close SaveChanges:=wdDoNotSaveChanges
Debug.Print num & ":" & wordFileName & "=" & myFileName
Shell "cmd.exe /c echo " & num & ":" & wordFileName & "=" & myFileName & ">>D:\Word.log"
End Sub
这个是Excel里的VBA代码，差不多的。

Option Explicit
Dim arrFiles()
Dim cntFiles%
Dim StartFolder$
Dim SavePath$

Sub Main()
Dim i%
Dim fso As New FileSystemObject, fd As Folder
ReDim arrFiles(1 To 1000)
cntFiles = 0
StartFolder = "D:\Excel" '原文件目录
SavePath = "D:\Excel2" '改名后的文件目录
Set fd = fso.GetFolder(StartFolder)
SearchFiles fd
ReDim Preserve arrFiles(1 To cntFiles)
For i = 1 To cntFiles
RenameDocument arrFiles(i), i
Next i
End Sub

Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl

In fd.Files
If LCase(Right(fl.Path, 4)) = ".xls" Then
cntFiles = cntFiles + 1
If cntFiles >= UBound(arrFiles) Then ReDim Preserve arrFiles(1 To cntFiles + 1000)
arrFiles(cntFiles) = fl.Path
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub

Sub RenameDocument(ByVal excelFileName, ByVal num)
On Error Resume Next
Dim myTitle$, myFileName$
myFileName = Mid(excelFileName, InStrRev(excelFileName, "\") + 1)
myTitle = GetValuesFromAClosedWorkbook(StartFolder, myFileName, "Sheet1", "A1")
myTitle = Trim(myTitle)
If myTitle = "" Then
Debug.Print "ERR:--------------------------------------------" & excelFileName
Shell "cmd.exe /c echo " & "ERR:--------------------------------------------" & excelFileName & ">>D:\Excel.log"
Application.SendKeys ("{ESC}")
Exit Sub
End If
myFileName = SavePath + "\" + myTitle + ".xls"
Debug.Print num & ":" & excelFileName & "=" & myFileName
Shell "cmd.exe /c echo " & num & ":" & excelFileName & "=" & myFileName & ">>D:\Excel.log"
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.CopyFile excelFileName, myFileName, True
End Sub

Function GetValuesFromAClosedWorkbook(fPath As String, fName As String, sName, cellRange As String) As String
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wk As Workbook, arr
Set wk = GetObject("" & fPath & "\" & fName & "")
arr = wk.Sheets(1).Range("A1")
GetValuesFromAClosedWorkbook = arr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function