批量转多文件夹内DOC为TXT,再合并TXT

'doc2txt.vbs    By yu2n,  2014.09.01
CommandMode "批量转多文件夹内DOC为TXT,再合并TXT"


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)
  objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
        "", False, False, False, False, False, Encoding, False, False, wdCRLF
  objDoc.Close
  If Not Err.Number = 0 Then Doc2Txt = True
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




' 创建 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




' 获取文件夹所有文件夹、文件列表(数组)
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




' 以命令提示符环境运行(保留参数)
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