批量提取某个文件夹下的全部word文件名及页面

loquat

以下代码使用shell.application获取word文档页数，可能会不准
可靠的方式要区分新旧文件格式：
对旧文件格式，doc等，要使用复合文档技术
用复合文档API StgOpenStorage和IPropertySetStorage读Page Count属性
对新文件格式，docx等，要使用xml读取技术
Open XML SDK打开文件之后读ExtendedFilePropertiesPart.Properties.Pages属性
但是实际对于新文件格式还可以直接解压获取文件中的app.xml文件，内有<Pages>xx</Pages>标签

1. Function GetPagesCount(ByVal flPath As String) As Integer
   
2. Dim fso As Object, fl As Object, shl As Object
   
3. Dim fdPath$, flName$, i&, shfd As Object
   
4. Set fso = CreateObject("Scripting.FileSystemObject")
   
5. Set fl = fso.GetFile(flPath)
   
6. fdPath = fl.ParentFolder.Path
   
7. flName = fl.Name
   
8. Set shl = CreateObject("Shell.Application")
   
9. Set shfd = shl.NameSpace(fdPath)
   
10. For i = 0 To 300
    
11.     If Left(shfd.GetDetailsOf(0, i), 1) = "页" Then  'XP中为"页数"，Win7中为"页码范围"，所有直接查找"页"
    
12.         GetPagesCount = shfd.GetDetailsOf(shfd.Items.Item(flName), i)
    
13.         Exit Function
    
14.     End If
    
15. Next i
    
16. End Function
    
17. 
    
18. Sub 遍历获取页数()
    
19. Application.ScreenUpdating = False
    
20. Dim fso As Object, objFolder As Object, ws As Object, Ext$, srcfolder$, dstfolder$, arr, aMsg
    
21. Dim aDic As Object, wdApp As Word.Application, strTemp$, aNum&, pgCount&, aPage&
    
22. Set wdApp = CreateObject("Word.Application")
    
23. Set fso = CreateObject("Scripting.FileSystemObject")
    
24. Set ws = CreateObject("WScript.Shell")
    
25. Set aDic = CreateObject("Scripting.Dictionary")
    
26. srcfolder = "C:\Documents and Settings\Administrator\桌面\新建文件夹"
    
27. ws.Run Environ$("comspec") & " /c dir " & Chr(34) & srcfolder & "\*.doc" & Chr(34) & " /s /b /a:-d > C:\tmpDoc.txt", 0, True '遍历获取Word文件，并列表到临时文件
    
28. aNum = FreeFile()
    
29. Open "C:\tmpDoc.txt" For Input As #aNum
    
30.     arr = Split(StrConv(InputB(LOF(aNum), aNum), vbUnicode), vbCrLf) '将遍历结果从文件读取到数组中
    
31. Close #1
    
32. ws.Run Environ$("comspec") & " /c del /q /s " & Chr(34) & "C:\tmpDoc.txt" & Chr(34), 0, True '删除临时文件
    
33. For i = LBound(arr) To UBound(arr) - 1
    
34.     If Left(fso.getfilename(arr(i)), 2) <> "~$" Then    '排除临时文件
    
35.         aPage = GetPagesCount(arr(i))
    
36.         pgCount = pgCount + aPage
    
37.         strTemp = strTemp & aPage & vbTab & arr(i) & Chr(13)
    
38.     End If
    
39. Next i
    
40. aNum = FreeFile()
    
41. Open "C:\PageCount.txt" For Output As #aNum
    
42.     Print #aNum, strTemp
    
43. Close #aNum
    
44. Set fso = Nothing '销毁fso对象，释放内存
    
45. Set ws = Nothing '销毁Shell对象，释放内存
    
46. MsgBox "统计总页数完毕，总页数：" & pgCount & vbCrLf & "C:\PageCount.txt为统计结果"
    
47. Application.ScreenUpdating = True
    
48. End Sub
    

复制代码

x332553761

好东西  先收下先，不然怕找不到

loquat

一个不同打开文档的方案。但是有时候可能不一定准确。。。参考

1. Function GetPagesCount(flPath As String) As Integer
   
2. Dim fso As Object, fl As Object, shl As Shell32.Shell
   
3. Dim fdPath$, flName$, i&, shfd As Shell32.Folder
   
4. Set fso = CreateObject("Scripting.FileSystemObject")
   
5. Set fl = fso.GetFile(flPath)
   
6. fdPath = fl.ParentFolder.Path
   
7. flName = fl.Name
   
8. Set shl = New Shell
   
9. Set shfd = shl.NameSpace(fdPath)
   
10. For i = 0 To 300
    
11.     If Left(shfd.GetDetailsOf(0, i), 1) = "页" Then  'XP中为"页数"，Win7中为"页码范围"，所有直接查找"页"
    
12.         GetPagesCount = shfd.GetDetailsOf(shfd.Items.Item(flName), i)
    
13.         Exit Function
    
14.     End If
    
15. Next i
    
16. End Function

复制代码

eh蝴蝶效应

daocao2003 发表于 2014-10-30 20:01
其实，建议楼主安装total commander，它里面提供了查看office文档的功能，太强大了，效果如下图，显示的结 ...

回看八年前的帖子，发现自己退步了。大咖熟悉Directory OPus吗？也是一款类似total command的软件。