【实验】Word批量重命名VBA代码

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

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