[已解决]为选定目录下的所有WORD文档名称加上总页数

yjwdjfqb

为选定目录下的所有WORD文档名称加上总页数

先谢谢各位大侠了！




统计.rar (77.79 KB, 下载次数: 9)

2014-3-30 19:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-3-30 21:13

1. Sub batchWordRename()
   
2.     Dim strPath As String, strFile As String, strNew$
   
3.     Dim wd As Document
   
4.     Dim lPage%
   
5.     On Error Resume Next
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         .InitialFileName = ThisDocument.Path
   
9.         If .Show Then
   
10.             strPath = .SelectedItems(1) & Application.PathSeparator
    
11.         Else
    
12.             MsgBox "没有选择要修改的文件夹"
    
13.             Exit Sub
    
14.         End If
    
15.     End With
    
16.     Application.DisplayAlerts = False
    
17.     Application.ScreenUpdating = False
    
18. 
    
19.     strFile = Dir(strPath & "*.doc")
    
20.     Do While Len(strFile)
    
21.         If strFile <> ThisDocument.Name And (Not strFile Like "*共*页*") Then
    
22.             Set wd = GetObject(strPath & strFile)
    
23.             If Not wd Is Nothing Then
    
24.                 With wd
    
25.                     Application.StatusBar = "正在处理 " & strPath & strFile
    
26.                     .ActiveWindow.Selection.EndKey Unit:=6
    
27.                     lPage = .BuiltInDocumentProperties(14)
    
28.                     .Close False
    
29.                     strNew = Left(strFile, InStrRev(strFile, ".") - 1) & "_共" & lPage & "页" & Mid(strFile, InStrRev(strFile, "."))
    
30.                     Name strPath & strFile As strPath & strNew
    
31.                 End With
    
32.             Else
    
33.                 MsgBox strPath & strFile & "打开失败"
    
34.             End If
    
35.         End If
    
36.         strFile = Dir
    
37.     Loop
    
38.     Application.StatusBar = False
    
39.     Application.DisplayAlerts = True
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "ok"
    
42. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

你上次的那个代码单页变多页的代码稍微一改就成了。

hwc2ycy

1. Sub batchWordRename()
   
2.     Dim strPath As String, strFile As String, strNew$
   
3.     Dim wd As Document
   
4.     Dim lPage%
   
5.     On Error Resume Next
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         .InitialFileName = ThisDocument.Path
   
9.         If .Show Then
   
10.             strPath = .SelectedItems(1) & Application.PathSeparator
    
11.         Else
    
12.             MsgBox "没有选择要修改的文件夹"
    
13.             Exit Sub
    
14.         End If
    
15.     End With
    
16.     Application.DisplayAlerts = False
    
17.     Application.ScreenUpdating = False
    
18. 
    
19.     strFile = Dir(strPath & "*.doc")
    
20.     Do While Len(strFile)
    
21.         If strFile <> ThisDocument.Name And (Not strFile Like "*页*") Then
    
22.             Set wd = GetObject(strPath & strFile)
    
23.             If Not wd Is Nothing Then
    
24.                 With wd
    
25.                     Application.StatusBar = "正在处理 " & strPath & strFile
    
26.                     .ActiveWindow.Selection.EndKey Unit:=6
    
27.                     lPage = .BuiltInDocumentProperties(14)
    
28.                     .Close False
    
29.                     strNew = Left(strFile, InStrRev(strFile, ".") - 1) & "_共" & lPage & "页" & Mid(strFile, InStrRev(strFile, "."))
    
30.                     Name strPath & strFile As strPath & strNew
    
31.                 End With
    
32.             Else
    
33.                 MsgBox strPath & strFile & "打开失败"
    
34.             End If
    
35.         End If
    
36.         strFile = Dir
    
37.     Loop
    
38.     Application.StatusBar = False
    
39.     Application.DisplayAlerts = True
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "ok"
    
42. End Sub

复制代码

hwc2ycy

1. Sub batchWordRename()
   
2.     Dim strPath As String, strFile As String, strNew$
   
3.     Dim wd As Document
   
4.     Dim lPage%
   
5.     On Error Resume Next
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         .InitialFileName = ThisDocument.Path
   
9.         If .Show Then
   
10.             strPath = .SelectedItems(1) & Application.PathSeparator
    
11.         Else
    
12.             MsgBox "没有选择要修改的文件夹"
    
13.             Exit Sub
    
14.         End If
    
15.     End With
    
16.     Application.DisplayAlerts = False
    
17.     Application.ScreenUpdating = False
    
18. 
    
19.     strFile = Dir(strPath & "*.doc")
    
20.     Do While Len(strFile)
    
21.         If strFile <> ThisDocument.Name And (Not strFile Like "*共*页*") Then
    
22.             Set wd = GetObject(strPath & strFile)
    
23.             If Not wd Is Nothing Then
    
24.                 With wd
    
25.                     Application.StatusBar = "正在处理 " & strPath & strFile
    
26.                     .ActiveWindow.Selection.EndKey Unit:=6
    
27.                     lPage = .BuiltInDocumentProperties(14)
    
28.                     .Close False
    
29.                     strNew = Left(strFile, InStrRev(strFile, ".") - 1) & "_共" & lPage & "页" & Mid(strFile, InStrRev(strFile, "."))
    
30.                     Name strPath & strFile As strPath & strNew
    
31.                 End With
    
32.             Else
    
33.                 MsgBox strPath & strFile & "打开失败"
    
34.             End If
    
35.         End If
    
36.         strFile = Dir
    
37.     Loop
    
38.     Application.StatusBar = False
    
39.     Application.DisplayAlerts = True
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "ok"
    
42. End Sub

复制代码

yjwdjfqb

hwc2ycy 发表于 2014-3-30 20:57
你上次的那个代码单页变多页的代码稍微一改就成了。

在那儿呢老师！

yjwdjfqb

hwc2ycy 发表于 2014-3-30 21:13

老师你好，我看三楼、四楼代码差不多，那个更好点呀！

hwc2ycy

4楼的避免二次重命名。随你便吧。