Board logo

标题: [文本处理] 批处理怎样用DocToText批量转多文件夹内DOC为TXT,再合并TXT [打印本页]

作者: wyx567    时间: 2014-9-1 12:15     标题: 批处理怎样用DocToText批量转多文件夹内DOC为TXT,再合并TXT

本帖最后由 wyx567 于 2014-9-1 12:59 编辑

在论坛里仔细搜索还是没发现好办法,求助!
怎么样用类似DocToText工具批量转换多个文件夹内(包括子目录)的DOC为TXT,文件夹内子文件夹内可能有多个doc,然后合并TXT再以各自文件夹名称重命名
比如:
c:\文件夹1\文件.doc
c:\文件夹2\3\文件1.doc
c:\文件夹3\4\5\文件2.doc
c:\文件夹4\5\6\7\文件3.doc
……
统一转换成

c:\文件夹1\文件夹1.txt
c:\文件夹2\文件夹2.txt
c:\文件夹3\文件夹3.txt
c:\文件夹4\文件夹4.txt
……

请问这样可以吗?
上万个文件夹,实在是没办法。

tmplinshi 大大在 2012-11-8 发过

要把中文转换成 utf-8。

把附件中的文件解压到 doctotext.exe 目录,之后使用方法如下:
doctotext_ *.doc
复制代码
doctotext_ 中文测试1.doc "中文 测试2.doc"
复制代码
文件搜索使用的是 dir 的语法。所以例如要搜索子目录的文件,则加 /s 参数:
doctotext_ /s *.doc
复制代码
doctotext_.bat:
@echo off
setlocal
set n=0
set skip=

dir /b %* | win_iconv -f gbk -t utf-8 >"%~f0.tmp"

for /f "delims=" %%a in (' dir /b %* ') do (
    call :doctotext "%%a"
)
exit /b

:doctotext
if %n% neq 0 (
    set skip=skip=%n%
)

for /f "usebackq %skip% eol=< delims=" %%a in ("%~f0.tmp") do (
    echo convert %1...
    doctotext "%%a" >"%~1.txt"
    set /a n += 1
    goto :eof
)

最新版本下载:
http://sourceforge.net/projects/doctotext/?source=typ_redirect
能不能在此基础上修改呢?
多谢各位!!
作者: yu2n    时间: 2014-9-1 22:44

本帖最后由 yu2n 于 2014-9-1 22:46 编辑

沙发~
我用VBS写了一个,使用Word的另存为功能,直接保存为TXT。
请将原文件夹备份后试试,很期待知道Word转换1W个DOC文档需要多长时间……
  1. 'doc2txt.vbs    By yu2n,  2014.09.01
  2. CommandMode "批量转多文件夹内DOC为TXT,再合并TXT"
  3. Main
  4. Sub Main()
  5.   On Error Resume Next
  6.   ' 选择文件夹
  7.   Dim strFolder, arrPath, strPath, nFileCount, i
  8.   WScript.Echo "请选择 Word 文件路径:"
  9.   strFolder = BrowseForFolder("请选择 Word 文件路径:")
  10.   If strFolder = "" Then Exit Sub
  11.   arrPath = ScanFolder(strFolder)
  12.   ' 统计个数,用于显示进度
  13.   For Each strPath In arrPath
  14.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  15.       nFileCount = nFileCount + 1
  16.     End If
  17.   Next
  18.   ' 执行转换
  19.   Set objWord = Word_Init()
  20.   For Each strPath In arrPath
  21.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  22.       i = i + 1
  23.   ' 显示进度
  24.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
  25.   ' 执行转换
  26.       Doc2Txt objWord, strPath
  27.   ' 追加TXT
  28.       CreatTxtFile strFolder, strPath
  29.     End If
  30.   Next
  31.   ' 退出
  32.   objWord.Quit
  33.   Msgbox "完成!"
  34. End Sub
  35. ' 打开DOC,另存为
  36. Function Doc2Txt(objWord, FilePath)
  37.   On Error Resume Next
  38.   Set fso = CreateObject("Scripting.Filesystemobject")
  39.   If Not fso.FileExists(FilePath) Then Exit Function
  40.   
  41.   Const wdFormatText = 2
  42.   Const Encoding = 1200
  43.   Const wdCRLF = 0
  44.   Set objDoc = objWord.Documents.Open(FilePath)
  45.   objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
  46.         "", False, False, False, False, False, Encoding, False, False, wdCRLF
  47.   objDoc.Close
  48.   If Not Err.Number = 0 Then Doc2Txt = True
  49. End Function
  50. ' 浏览文件夹
  51. Function BrowseForFolder(ByVal strTips)
  52.   Dim objFolder
  53.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  54.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  55. End Function
  56. ' 创建 Word 对象
  57. Function Word_Init()
  58.   Set objWord = CreateObject("Word.Application")
  59.   If Not Err.Number = 0 Then
  60.     Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。"
  61.     WScript.Quit(999)
  62.   End If
  63.   If Not objWord.Application.Version >= 12.0 Then
  64.     Msgbox "警告:请使用 Office 2007 以上版本。"
  65.   End If
  66.   ' 隐藏运行,屏蔽提示
  67.   objWord.Visible = False
  68.   objWord.DisplayAlerts = False
  69.   Set Word_Init = objWord
  70. End Function
  71. '将转换后的TXT追加到指定文件
  72. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)
  73.     Set fso = CreateObject("Scripting.FileSystemObject")
  74.     If Not fso.FileExists(strFilePath & ".txt") Then Exit Function
  75.     ' 整理路径
  76.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)
  77.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)
  78.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"
  79.     ' 打开转换后的TXT文件
  80.     Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)
  81.     strText = rTxt.ReadAll()
  82.     rTxt.Close
  83.     ' 删除转换后的文件
  84.     fso.DeleteFile strFilePath & ".txt", True
  85.     ' 将转换后的TXT追加到指定文件
  86.     Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)
  87.     wTxt.Write strText
  88.     wTxt.Close
  89. End Function
  90. ' 获取文件夹所有文件夹、文件列表(数组)
  91. Function ScanFolder(ByVal strPath)
  92.     Dim arr()
  93.     ReDim Preserve arr(0)
  94.     Call SCAN_FOLDER(arr, strPath)
  95.     ReDim Preserve arr(UBound(arr) - 1)
  96.     ScanFolder = arr
  97. End Function
  98. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  99.     On Error Resume Next
  100.     Dim fso, objItems, objFile, objFolder
  101.     Set fso = CreateObject("Scripting.FileSystemObject")
  102.     Set objItems = fso.GetFolder(folderSpec)
  103.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  104.     If (Not fso.FolderExists(folderSpec)) Then Exit Function
  105.     For Each objFile In objItems.Files
  106.         arr(UBound(arr)) = objFile.Path
  107.         ReDim Preserve arr(UBound(arr) + 1)
  108.     Next
  109.     For Each objFolder In objItems.subfolders
  110.         Call SCAN_FOLDER(arr, objFolder.Path)
  111.     Next
  112.     arr(UBound(arr)) = folderSpec
  113.     ReDim Preserve arr(UBound(arr) + 1)
  114. End Function
  115. ' 以命令提示符环境运行(保留参数)
  116. Sub CommandMode(ByVal sTitle)
  117.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
  118.         Dim i, sArgs
  119.         For i = 1 To WScript.Arguments.Count
  120.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
  121.         Next
  122.         CreateObject("WScript.Shell").Run( _
  123.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _
  124.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3
  125.             Wscript.Quit
  126.     End If
  127. End Sub
复制代码

作者: wyx567    时间: 2014-9-5 16:27

我来测试下,多谢楼上兄弟!
作者: wyx567    时间: 2014-9-5 18:27

回复 2# yu2n


    效果很好!
不过在转换中,会出现:

选择关闭后,WORD就在前台显示,文件一个一个打开,关闭。
不过转换合并还在正常继续

出来一个另存为画面,到这个提示后,不管怎么选择,确定后WORD关闭,vbs快速跳过没转换的DOC列表,提示关闭。
我想能不能关闭WORD的查错功能,应该就没问题了
作者: wyx567    时间: 2014-9-5 18:47

出问题的都是在DOCX上,我下载个office2010试试,现在用的2007 sp3
作者: yu2n    时间: 2014-9-5 19:05

回复 5# wyx567
这个问题我没有碰到过,可以把出错的Word文档打包几个传上来看看?
作者: wyx567    时间: 2014-9-5 19:46

回复 6# yu2n
换了office2010,转换速度明显提高

但这个坎还是过不去。。
提示另存为,直接确定,或者另存为doc格式都提示word错误重启。
链接:http://pan.baidu.com/s/1jG1euFW 密码:ryaz
我把文件传到百度云了,有空您看看

多谢!
作者: yu2n    时间: 2014-9-5 21:47

回复 7# wyx567

这个文档格式可能有问题,该文档直接手动另存为会出错,暂时不知道出错原因。

既然如此,就不使用另存为功能。换个方法,直接获取Doc文本内容,写入txt文件。
  1. CommandMode "VBS 批量转多文件夹内DOC为TXT,再合并TXT  By  Yu2n@qq.com"
  2. Main
  3. Sub Main()
  4.   On Error Resume Next
  5.   ' 选择文件夹
  6.   Dim strFolder, arrPath, strPath, nFileCount, i
  7.   WScript.Echo "请选择 Word 文件路径:"
  8.   strFolder = BrowseForFolder("请选择 Word 文件路径:")
  9.   If strFolder = "" Then Exit Sub
  10.   arrPath = ScanFolder(strFolder)
  11.   ' 统计个数,用于显示进度
  12.   For Each strPath In arrPath
  13.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  14.       nFileCount = nFileCount + 1
  15.     End If
  16.   Next
  17.   ' 执行转换
  18.   Set objWord = Word_Init()
  19.   For Each strPath In arrPath
  20.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  21.       i = i + 1
  22.   ' 显示进度
  23.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
  24.   ' 执行转换
  25.       Doc2Txt objWord, strPath
  26.   ' 追加TXT
  27.       CreatTxtFile strFolder, strPath
  28.     End If
  29.   Next
  30.   ' 退出
  31.   objWord.Quit
  32.   Msgbox "完成!"
  33. End Sub
  34. ' 打开DOC,另存为
  35. Function Doc2Txt(objWord, FilePath)
  36.   On Error Resume Next
  37.   Set fso = CreateObject("Scripting.Filesystemobject")
  38.   If Not fso.FileExists(FilePath) Then Exit Function
  39.   
  40.   Const wdFormatText = 2
  41.   Const Encoding = 1200
  42.   Const wdCRLF = 0
  43.   Set objDoc = objWord.Documents.Open(FilePath)
  44.   
  45.   ' 另存为,wyx567反映个别Docx出错
  46.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
  47.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF
  48.   
  49.   ' 获取Doc文本内容
  50.   strContent = objDoc.Content
  51.   strContent = Replace(strContent, vbCr, vbCrLf)
  52.   objDoc.Close False
  53.   
  54.   ' 保存Doc文本内容到txt文件
  55.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 8, True, -1)
  56.   wTxt.Write strContent
  57.   wTxt.Close
  58.   If Not Err.Number = 0 Then Doc2Txt = True
  59. End Function
  60. ' 浏览文件夹
  61. Function BrowseForFolder(ByVal strTips)
  62.   Dim objFolder
  63.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  64.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  65. End Function
  66. ' 创建 Word 对象
  67. Function Word_Init()
  68.   Set objWord = CreateObject("Word.Application")
  69.   If Not Err.Number = 0 Then
  70.     Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。"
  71.     WScript.Quit(999)
  72.   End If
  73.   If Not objWord.Application.Version >= 12.0 Then
  74.     Msgbox "警告:请使用 Office 2007 以上版本。"
  75.   End If
  76.   ' 隐藏运行,屏蔽提示
  77.   objWord.Visible = False
  78.   objWord.DisplayAlerts = False
  79.   Set Word_Init = objWord
  80. End Function
  81. '将转换后的TXT追加到指定文件
  82. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)
  83.     Set fso = CreateObject("Scripting.FileSystemObject")
  84.     If Not fso.FileExists(strFilePath & ".txt") Then Exit Function
  85.     ' 整理路径
  86.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)
  87.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)
  88.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"
  89.     ' 打开转换后的TXT文件
  90.     Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)
  91.     strText = rTxt.ReadAll()
  92.     rTxt.Close
  93.     ' 删除转换后的文件
  94.     fso.DeleteFile strFilePath & ".txt", True
  95.     ' 将转换后的TXT追加到指定文件
  96.     Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)
  97.     wTxt.Write strText
  98.     wTxt.Close
  99. End Function
  100. ' 获取文件夹所有文件夹、文件列表(数组)
  101. Function ScanFolder(ByVal strPath)
  102.     Dim arr()
  103.     ReDim Preserve arr(0)
  104.     Call SCAN_FOLDER(arr, strPath)
  105.     ReDim Preserve arr(UBound(arr) - 1)
  106.     ScanFolder = arr
  107. End Function
  108. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  109.     On Error Resume Next
  110.     Dim fso, objItems, objFile, objFolder
  111.     Set fso = CreateObject("Scripting.FileSystemObject")
  112.     Set objItems = fso.GetFolder(folderSpec)
  113.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  114.     If (Not fso.FolderExists(folderSpec)) Then Exit Function
  115.     For Each objFile In objItems.Files
  116.         arr(UBound(arr)) = objFile.Path
  117.         ReDim Preserve arr(UBound(arr) + 1)
  118.     Next
  119.     For Each objFolder In objItems.subfolders
  120.         Call SCAN_FOLDER(arr, objFolder.Path)
  121.     Next
  122.     arr(UBound(arr)) = folderSpec
  123.     ReDim Preserve arr(UBound(arr) + 1)
  124. End Function
  125. ' 以命令提示符环境运行(保留参数)
  126. Sub CommandMode(ByVal sTitle)
  127.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
  128.         Dim i, sArgs
  129.         For i = 1 To WScript.Arguments.Count
  130.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
  131.         Next
  132.         CreateObject("WScript.Shell").Run( _
  133.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _
  134.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3
  135.             Wscript.Quit
  136.     End If
  137. End Sub
复制代码

作者: wyx567    时间: 2014-9-5 23:09

我再试试!楼上牛逼!

感谢感谢!!
作者: wyx567    时间: 2014-9-10 18:13

这次批量转了1000个文件夹,这次没有docx了  有时会出现个这个框

上一次显示修复的提示框还是会出现

已经很好了,感谢感谢!!!
作者: wyx567    时间: 2014-9-10 19:36

回复 6# yu2n

您好,
大量文档中有很多这样的空白回车,怎么样能批量消除或者把多行换行回车换成1行换行回车呢。
[attach]7664[/attach]

还有就是怎么能批量保留TXT文件的前面,比如300行,300行以后的删除,能不能实现这样的效果呢

多谢!
作者: yu2n    时间: 2014-9-10 20:37

回复 11# wyx567
新增格式化字符串函数 FormatText :
  1. CommandMode "VBS 批量转多文件夹内DOC为TXT,再合并TXT  By  Yu2n@qq.com"
  2. Main
  3. Sub Main()
  4.   On Error Resume Next
  5.   ' 选择文件夹
  6.   Dim strFolder, arrPath, strPath, nFileCount, i
  7.   WScript.Echo "请选择 Word 文件路径:"
  8.   strFolder = BrowseForFolder("请选择 Word 文件路径:")
  9.   If strFolder = "" Then Exit Sub
  10.   arrPath = ScanFolder(strFolder)
  11.   ' 统计个数,用于显示进度
  12.   For Each strPath In arrPath
  13.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  14.       nFileCount = nFileCount + 1
  15.     End If
  16.   Next
  17.   ' 执行转换
  18.   Set objWord = Word_Init()
  19.   For Each strPath In arrPath
  20.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  21.       i = i + 1
  22.   ' 显示进度
  23.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
  24.   ' 执行转换
  25.       Doc2Txt objWord, strPath
  26.   ' 追加TXT
  27.       CreatTxtFile strFolder, strPath
  28.     End If
  29.   Next
  30.   ' 退出
  31.   objWord.Quit
  32.   Msgbox "完成!"
  33. End Sub
  34. ' 打开DOC,另存为
  35. Function Doc2Txt(objWord, FilePath)
  36.   On Error Resume Next
  37.   Set fso = CreateObject("Scripting.Filesystemobject")
  38.   If Not fso.FileExists(FilePath) Then Exit Function
  39.   
  40.   Const wdFormatText = 2
  41.   Const Encoding = 1200
  42.   Const wdCRLF = 0
  43.   Set objDoc = objWord.Documents.Open(FilePath)
  44.   
  45.   ' 另存为,wyx567反映个别Docx出错
  46.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
  47.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF
  48.   
  49.   ' 获取Doc文本内容
  50.   strContent = objDoc.Content
  51.   objDoc.Close False
  52.   
  53.   ' 保存Doc文本内容到txt文件
  54.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 8, True, -1)
  55.   wTxt.Write FormatText(strContent)
  56.   wTxt.Close
  57.   If Not Err.Number = 0 Then Doc2Txt = True
  58. End Function
  59. ' 创建 Word 对象
  60. Function Word_Init()
  61.   Set objWord = CreateObject("Word.Application")
  62.   If Not Err.Number = 0 Then
  63.     Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。"
  64.     WScript.Quit(999)
  65.   End If
  66.   If Not objWord.Application.Version >= 12.0 Then
  67.     Msgbox "警告:请使用 Office 2007 以上版本。"
  68.   End If
  69.   ' 隐藏运行,屏蔽提示
  70.   objWord.Visible = False
  71.   objWord.DisplayAlerts = False
  72.   Set Word_Init = objWord
  73. End Function
  74. '将转换后的TXT追加到指定文件
  75. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)
  76.     Set fso = CreateObject("Scripting.FileSystemObject")
  77.     If Not fso.FileExists(strFilePath & ".txt") Then Exit Function
  78.     ' 整理路径
  79.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)
  80.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)
  81.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"
  82.     ' 打开转换后的TXT文件
  83.     Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)
  84.     strText = rTxt.ReadAll()
  85.     rTxt.Close
  86.     ' 删除转换后的文件
  87.     fso.DeleteFile strFilePath & ".txt", True
  88.     ' 将转换后的TXT追加到指定文件
  89.     Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)
  90.     wTxt.Write strText
  91.     wTxt.Close
  92. End Function
  93. ' 以命令提示符环境运行(保留参数)
  94. Sub CommandMode(ByVal sTitle)
  95.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
  96.         Dim i, sArgs
  97.         For i = 1 To WScript.Arguments.Count
  98.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
  99.         Next
  100.         CreateObject("WScript.Shell").Run( _
  101.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _
  102.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3
  103.             Wscript.Quit
  104.     End If
  105. End Sub
  106. ' 格式化字符串
  107. Function FormatText(ByVal str)
  108. ' 删除空行
  109. str = Replace(str, vbLf, "")
  110. str = Replace(str, vbCr, vbCrLf)
  111. str = regEx_replace("^\s*\r\n", str, "")
  112. ' 取前300行
  113. arrStr = Split(str, vbCrLf)
  114. If UBound(arrStr)>(300-1) Then ReDim Preserve arrStr(300-1)
  115. str = Join(arrStr, vbCrLf)
  116. FormatText = str
  117. End Function
  118. ' 正则表达式替换
  119. Function regEx_replace(ByVal sPattern, ByVal str, ByVal sReplace)
  120. Dim regEx                      ' 建立变量。
  121.     Set regEx = CreateObject("VBScript.RegExp")  ' 建立正则表达式。
  122.         regEx.Pattern = sPattern   ' 设置模式。
  123.         regEx.IgnoreCase = True    ' 设置是否区分字符大小写。
  124.         regEx.Global = True        ' 设置全局可用性。
  125.         regEx.MultiLine = True     ' 多行匹配模式
  126. regEx_replace = regEx.Replace(str, sReplace)   ' 作替换。
  127. Set regEx = Nothing
  128. End Function
  129. ' 浏览文件夹
  130. Function BrowseForFolder(ByVal strTips)
  131.   Dim objFolder
  132.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  133.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  134. End Function
  135. ' 获取文件夹所有文件夹、文件列表(数组)
  136. Function ScanFolder(ByVal strPath)
  137.     Dim arr()
  138.     ReDim Preserve arr(0)
  139.     Call SCAN_FOLDER(arr, strPath)
  140.     ReDim Preserve arr(UBound(arr) - 1)
  141.     ScanFolder = arr
  142. End Function
  143. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  144.     On Error Resume Next
  145.     Dim fso, objItems, objFile, objFolder
  146.     Set fso = CreateObject("Scripting.FileSystemObject")
  147.     Set objItems = fso.GetFolder(folderSpec)
  148.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  149.     If (Not fso.FolderExists(folderSpec)) Then Exit Function
  150.     For Each objFile In objItems.Files
  151.         arr(UBound(arr)) = objFile.Path
  152.         ReDim Preserve arr(UBound(arr) + 1)
  153.     Next
  154.     For Each objFolder In objItems.subfolders
  155.         Call SCAN_FOLDER(arr, objFolder.Path)
  156.     Next
  157.     arr(UBound(arr)) = folderSpec
  158.     ReDim Preserve arr(UBound(arr) + 1)
  159. End Function
复制代码

作者: wyx567    时间: 2014-9-11 16:27

回复 12# yu2n

您好,使用新的代码,和上一次的情况一样,出现显示修复和上次截图的对话框。

我把对话框的文件发出来您有空看看

链接:http://pan.baidu.com/s/1pJnxfEb 密码:8vlf

真心感谢您的无私帮助!!
作者: yu2n    时间: 2014-9-11 20:33

回复 13# wyx567
这个Doc文档带了宏,并且设置了开启时弹出这个窗口。
百度暂时找不到在运行前移除这些VBA过程的方法。
作者: wyx567    时间: 2014-9-12 12:44

回复 14# yu2n

好的,这样的文件并不多,可以解决。
非常感谢您的帮助!
作者: yu2n    时间: 2014-9-12 14:13

本帖最后由 yu2n 于 2014-9-12 14:20 编辑

回复 15# wyx567
总算让我找到这篇文章:
  1. VBA打开文件时(临时)禁用宏
  2. http://club.excelhome.net/thread-1001802-1-1.html
复制代码
于是,可以消灭那个对话框了。
  1. CommandMode "VBS 批量转多文件夹内DOC为TXT,再合并TXT  By  Yu2n@qq.com"
  2. Main
  3. Sub Main()
  4.   On Error Resume Next
  5.   ' 选择文件夹
  6.   Dim strFolder, arrPath, strPath, nFileCount, i
  7.   WScript.Echo "请选择 Word 文件路径:"
  8.   strFolder = BrowseForFolder("请选择 Word 文件路径:")
  9.   If strFolder = "" Then Exit Sub
  10.   arrPath = ScanFolder(strFolder)
  11.   ' 统计个数,用于显示进度
  12.   For Each strPath In arrPath
  13.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  14.       nFileCount = nFileCount + 1
  15.     End If
  16.   Next
  17.   ' 执行转换
  18.   Set objWord = Word_Init()
  19.   For Each strPath In arrPath
  20.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then
  21.       i = i + 1
  22.       ' 显示进度
  23.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
  24.       ' 执行转换
  25.       Doc2Txt objWord, strPath
  26.       ' 追加TXT
  27.       CreatTxtFile strFolder, strPath
  28.     End If
  29.   Next
  30.   ' 退出
  31.   objWord.Quit
  32.   Msgbox "完成!"
  33. End Sub
  34. ' 打开DOC,另存为
  35. Function Doc2Txt(objWord, FilePath)
  36.   On Error Resume Next
  37.   Set fso = CreateObject("Scripting.Filesystemobject")
  38.   If Not fso.FileExists(FilePath) Then Exit Function
  39.   Set objDoc = objWord.Documents.Open(FilePath)
  40.   ' 方法一、另存为,wyx567反映个别Docx出错
  41.   ' Const wdFormatText = 2
  42.   ' Const Encoding = 1200
  43.   ' Const wdCRLF = 0
  44.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _
  45.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF
  46.   ' 方法二、直接获取Doc文本内容
  47.   strContent = objDoc.Content
  48.   objDoc.Close False
  49.   ' 保存Doc文本内容到txt文件
  50.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 2, True, -1)
  51.   wTxt.Write FormatText(strContent)
  52.   wTxt.Close
  53.   If Not Err.Number = 0 Then Doc2Txt = True
  54. End Function
  55. ' 创建 Word 对象
  56. Function Word_Init()
  57.   Const msoAutomationSecurityForceDisable = 3
  58.   Set objWord = CreateObject("Word.Application")
  59.   If Not Err.Number = 0 Then
  60.     Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。"
  61.     WScript.Quit(999)
  62.   End If
  63.   If Not objWord.Application.Version >= 12.0 Then
  64.     Msgbox "警告:请使用 Office 2007 以上版本。"
  65.   End If
  66.   ' 隐藏运行,屏蔽提示
  67.   objWord.Visible = False
  68.   objWord.DisplayAlerts = False
  69.   ' 禁用以编程方式打开的所有文件中的所有宏,而不显示任何安全警告。
  70.   ' VBA打开文件时(临时)禁用宏
  71.   ' http://club.excelhome.net/thread-1001802-1-1.html
  72.   objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  73.   Set Word_Init = objWord
  74. End Function
  75. '将转换后的TXT追加到指定文件
  76. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)
  77.   Set fso = CreateObject("Scripting.FileSystemObject")
  78.   If Not fso.FileExists(strFilePath & ".txt") Then Exit Function
  79.     ' 整理路径
  80.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)
  81.     If InStr(strSubFolderName, "\") > 0 Then
  82.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)
  83.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"
  84.   Else
  85.     strTxtFile = strFolderPath & "\" & strSubFolderName & ".txt"
  86.   End If
  87.   ' 打开转换后的TXT文件
  88.   Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)
  89.   strText = rTxt.ReadAll()
  90.   rTxt.Close
  91.   ' 删除转换后的文件
  92.   fso.DeleteFile strFilePath & ".txt", True
  93.   ' 将转换后的TXT追加到指定文件
  94.   Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)
  95.   wTxt.Write strText
  96.   wTxt.Close
  97. End Function
  98. ' 以命令提示符环境运行(保留参数)
  99. Sub CommandMode(ByVal sTitle)
  100.   If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
  101.     Dim i, sArgs
  102.     For i = 1 To WScript.Arguments.Count
  103.       sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
  104.     Next
  105.     CreateObject("WScript.Shell").Run( _
  106.       "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _
  107.       WScript.ScriptFullName & """ " & sArgs & " &pause"),3
  108.       Wscript.Quit
  109.   End If
  110. End Sub
  111. ' 格式化字符串
  112. Function FormatText(ByVal str)
  113.   ' 删除空行
  114.   str = Replace(str, vbLf, "")
  115.   str = Replace(str, vbCr, vbCrLf)
  116.   str = regEx_replace("^\s*\r\n", str, "")
  117.   ' 取前300行
  118.   arrStr = Split(str, vbCrLf)
  119.   If UBound(arrStr)>(300-1) Then ReDim Preserve arrStr(300-1)
  120.   str = Join(arrStr, vbCrLf)
  121.   FormatText = str
  122. End Function
  123. ' 正则表达式替换
  124. Function regEx_replace(ByVal sPattern, ByVal str, ByVal sReplace)
  125.   Dim regEx                      ' 建立变量。
  126.   Set regEx = CreateObject("VBScript.RegExp")  ' 建立正则表达式。
  127.   regEx.Pattern = sPattern   ' 设置模式。
  128.   regEx.IgnoreCase = True    ' 设置是否区分字符大小写。
  129.   regEx.Global = True        ' 设置全局可用性。
  130.   regEx.MultiLine = True     ' 多行匹配模式
  131.   regEx_replace = regEx.Replace(str, sReplace)   ' 作替换。
  132.   Set regEx = Nothing
  133. End Function
  134. ' 浏览文件夹
  135. Function BrowseForFolder(ByVal strTips)
  136.   Dim objFolder
  137.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  138.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  139. End Function
  140. ' 获取文件夹所有文件夹、文件列表(数组)
  141. Function ScanFolder(ByVal strPath)
  142.   Dim arr()
  143.   ReDim Preserve arr(0)
  144.   Call SCAN_FOLDER(arr, strPath)
  145.   ReDim Preserve arr(UBound(arr) - 1)
  146.   ScanFolder = arr
  147. End Function
  148. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  149.   On Error Resume Next
  150.   Dim fso, objItems, objFile, objFolder
  151.   Set fso = CreateObject("Scripting.FileSystemObject")
  152.   Set objItems = fso.GetFolder(folderSpec)
  153.   If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  154.   If (Not fso.FolderExists(folderSpec)) Then Exit Function
  155.   For Each objFile In objItems.Files
  156.     arr(UBound(arr)) = objFile.Path
  157.     ReDim Preserve arr(UBound(arr) + 1)
  158.   Next
  159.   For Each objFolder In objItems.subfolders
  160.     Call SCAN_FOLDER(arr, objFolder.Path)
  161.   Next
  162.   arr(UBound(arr)) = folderSpec
  163.   ReDim Preserve arr(UBound(arr) + 1)
  164. End Function
复制代码

作者: g99    时间: 2014-12-28 22:16

回复 16# yu2n


    运行流畅,速度极快!




欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2