yu2n

回复 15# wyx567
总算让我找到这篇文章：

VBA打开文件时（临时）禁用宏
http://club.excelhome.net/thread-1001802-1-1.htmlCOPY

于是，可以消灭那个对话框了。

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
  Set objDoc = objWord.Documents.Open(FilePath)
  ' 方法一、另存为，wyx567反映个别Docx出错
  ' Const wdFormatText = 2
  ' Const Encoding = 1200
  ' Const wdCRLF = 0
  ' 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", 2, True, -1)
  wTxt.Write FormatText(strContent)
  wTxt.Close
  If Not Err.Number = 0 Then Doc2Txt = True
End Function
 
 
' 创建 Word 对象
Function Word_Init()
  Const msoAutomationSecurityForceDisable = 3
  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
  ' 禁用以编程方式打开的所有文件中的所有宏，而不显示任何安全警告。
  ' VBA打开文件时（临时）禁用宏
  ' http://club.excelhome.net/thread-1001802-1-1.html
  objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  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)
    If InStr(strSubFolderName, "\") > 0 Then
    strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)
    strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"
  Else
    strTxtFile = strFolderPath & "\" & strSubFolderName & ".txt"
  End If
  ' 打开转换后的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 FunctionCOPY

g99

回复 16# yu2n


    运行流畅，速度极快！