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

2009年12月31日 | 分类: 技术相关 | 标签: , , ,

朋友有个问题找我帮忙,说是要把一大堆的Word文件按Word的标题(也可以说是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

这个是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
  1. lee
    2010年6月9日14:27

    用户定义类型未定义,为什么啊?

  2. 2010年6月21日17:21

    @lee
    可能因为你安装的Office不完整吧!

注意: 评论者允许使用'@user空格'的方式将自己的评论通知另外评论者。例如, ABC是本文的评论者之一,则使用'@ABC '(不包括单引号)将会自动将您的评论发送给ABC。使用'@all ',将会将评论发送给之前所有其它评论者。请务必注意user必须和评论者名相匹配(大小写一致)。