回复 11# wyx567
新增格式化字符串函数 FormatText ：- 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
- ' 追加TXT
- CreatTxtFile strFolder, strPath
- End If
- Next
- ' 退出
- objWord.Quit
- Msgbox "完成！"
- End Sub
-
-
- ' 打开DOC，另存为
- 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)
-
- ' 另存为，wyx567反映个别Docx出错
- ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
- ' "", False, False, False, False, False, Encoding, False, False, wdCRLF
-
- ' 获取Doc文本内容
- strContent = objDoc.Content
- objDoc.Close False
-
- ' 保存Doc文本内容到txt文件
- 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
-
-
- ' 创建 Word 对象
- 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
-
-
- '将转换后的TXT追加到指定文件
- 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"
-
- ' 打开转换后的TXT文件
- Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)
- strText = rTxt.ReadAll()
- rTxt.Close
- ' 删除转换后的文件
- fso.DeleteFile strFilePath & ".txt", True
- ' 将转换后的TXT追加到指定文件
- 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, "")
- ' 取前300行
- 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 'objFolder.Items().Item().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 Function
|
发表于 2014-9-1 12:15
| 
