| CommandMode "VBS 批量转多文件夹内DOC为TXT,再合并TXT By Ｙu２n＠qq.com" |
| |
| Main |
| Sub Main() |
| On Error Resume Next |
| |
| Dim strFolder, arrPath, strPath, nFileCount, i |
| WScript.Echo "请选择 Word 文件路径：" |
| strFolder = BrowseForFolder("请选择 Word 文件路径：") |
| If strFolder = "" Then Exit Sub |
| arrPath = ScanFolder(strFolder) |
| |
| For Each strPath In arrPath |
| If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then |
| nFileCount = nFileCount + 1 |
| End If |
| Next |
| |
| Set objWord = Word_Init() |
| For Each strPath In arrPath |
| If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then |
| i = i + 1 |
| |
| WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath |
| |
| Doc2Txt objWord, strPath |
| |
| CreatTxtFile strFolder, strPath |
| End If |
| Next |
| |
| objWord.Quit |
| Msgbox "完成！" |
| End Sub |
| |
| |
| |
| Function Doc2Txt(objWord, FilePath) |
| On Error Resume Next |
| Set fso = CreateObject("Scripting.Filesystemobject") |
| If Not fso.FileExists(FilePath) Then Exit Function |
| |
| Const wdFormatText = 2 |
| Const Encoding = 1200 |
| Const wdCRLF = 0 |
| Set objDoc = objWord.Documents.Open(FilePath) |
| |
| |
| |
| |
| |
| |
| strContent = objDoc.Content |
| objDoc.Close False |
| |
| |
| Set wTxt = fso.OpenTextFile(FilePath & ".txt", 8, True, -1) |
| wTxt.Write FormatText(strContent) |
| wTxt.Close |
| If Not Err.Number = 0 Then Doc2Txt = True |
| End Function |
| |
| |
| |
| Function Word_Init() |
| Set objWord = CreateObject("Word.Application") |
| If Not Err.Number = 0 Then |
| Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。" |
| WScript.Quit(999) |
| End If |
| If Not objWord.Application.Version >= 12.0 Then |
| Msgbox "警告：请使用 Office 2007 以上版本。" |
| End If |
| |
| objWord.Visible = False |
| objWord.DisplayAlerts = False |
| Set Word_Init = objWord |
| End Function |
| |
| |
| |
| Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath) |
| Set fso = CreateObject("Scripting.FileSystemObject") |
| If Not fso.FileExists(strFilePath & ".txt") Then Exit Function |
| |
| strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2) |
| strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1) |
| strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt" |
| |
| |
| Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1) |
| strText = rTxt.ReadAll() |
| rTxt.Close |
| |
| fso.DeleteFile strFilePath & ".txt", True |
| |
| Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1) |
| wTxt.Write strText |
| wTxt.Close |
| End Function |
| |
| |
| |
| Sub CommandMode(ByVal sTitle) |
| If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then |
| Dim i, sArgs |
| For i = 1 To WScript.Arguments.Count |
| sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """" |
| Next |
| CreateObject("WScript.Shell").Run( _ |
| "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo """ & _ |
| WScript.ScriptFullName & """ " & sArgs & " &pause"),3 |
| Wscript.Quit |
| End If |
| End Sub |
| |
| |
| |
| Function FormatText(ByVal str) |
| |
| str = Replace(str, vbLf, "") |
| str = Replace(str, vbCr, vbCrLf) |
| str = regEx_replace("^\s*\r\n", str, "") |
| |
| arrStr = Split(str, vbCrLf) |
| If UBound(arrStr)>(300-1) Then ReDim Preserve arrStr(300-1) |
| str = Join(arrStr, vbCrLf) |
| FormatText = str |
| End Function |
| |
| |
| |
| Function regEx_replace(ByVal sPattern, ByVal str, ByVal sReplace) |
| Dim regEx |
| Set regEx = CreateObject("VBScript.RegExp") |
| regEx.Pattern = sPattern |
| regEx.IgnoreCase = True |
| regEx.Global = True |
| regEx.MultiLine = True |
| regEx_replace = regEx.Replace(str, sReplace) |
| Set regEx = Nothing |
| End Function |
| |
| |
| |
| Function BrowseForFolder(ByVal strTips) |
| Dim objFolder |
| Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001) |
| If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path |
| End Function |
| |
| |
| |
| Function ScanFolder(ByVal strPath) |
| Dim arr() |
| ReDim Preserve arr(0) |
| Call SCAN_FOLDER(arr, strPath) |
| ReDim Preserve arr(UBound(arr) - 1) |
| ScanFolder = arr |
| End Function |
| Function SCAN_FOLDER(ByRef arr, ByVal folderSpec) |
| On Error Resume Next |
| Dim fso, objItems, objFile, objFolder |
| Set fso = CreateObject("Scripting.FileSystemObject") |
| Set objItems = fso.GetFolder(folderSpec) |
| If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\" |
| If (Not fso.FolderExists(folderSpec)) Then Exit Function |
| For Each objFile In objItems.Files |
| arr(UBound(arr)) = objFile.Path |
| ReDim Preserve arr(UBound(arr) + 1) |
| Next |
| For Each objFolder In objItems.subfolders |
| Call SCAN_FOLDER(arr, objFolder.Path) |
| Next |
| arr(UBound(arr)) = folderSpec |
| ReDim Preserve arr(UBound(arr) + 1) |
| End FunctionCOPY |
发表于 2014-9-1 12:15
| 
