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. 

  4. Main

  5. Sub Main()

  6.   On Error Resume Next

  7.   ' 选择文件夹

  8.   Dim strFolder, arrPath, strPath, nFileCount, i

  9.   WScript.Echo "请选择 Word 文件路径："

  10.   strFolder = BrowseForFolder("请选择 Word 文件路径：")

  11.   If strFolder = "" Then Exit Sub

  12.   arrPath = ScanFolder(strFolder)

  13.   ' 统计个数，用于显示进度

  14.   For Each strPath In arrPath

  15.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then

  16.       nFileCount = nFileCount + 1

  17.     End If

  18.   Next

  19.   ' 执行转换

  20.   Set objWord = Word_Init()

  21.   For Each strPath In arrPath

  22.     If LCase(Right(strPath,4))=".doc" Or LCase(Right(strPath,5))=".docx" Then

  23.       i = i + 1

  24. 	  ' 显示进度

  25.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath

  26. 	  ' 执行转换

  27.       Doc2Txt objWord, strPath

  28. 	  ' 追加TXT

  29.       CreatTxtFile strFolder, strPath

  30.     End If

  31.   Next

  32.   ' 退出

  33.   objWord.Quit

  34.   Msgbox "完成！"

  35. End Sub

  36. 

  37. 

  38. ' 打开DOC，另存为

  39. Function Doc2Txt(objWord, FilePath)

  40.   On Error Resume Next

  41.   Set fso = CreateObject("Scripting.Filesystemobject")

  42.   If Not fso.FileExists(FilePath) Then Exit Function

  43.   

  44.   Const wdFormatText = 2

  45.   Const Encoding = 1200

  46.   Const wdCRLF = 0

  47.   Set objDoc = objWord.Documents.Open(FilePath)

  48.   objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _

  49.         "", False, False, False, False, False, Encoding, False, False, wdCRLF

  50.   objDoc.Close

  51.   If Not Err.Number = 0 Then Doc2Txt = True

  52. End Function

  53. 

  54. 

  55. ' 浏览文件夹

  56. Function BrowseForFolder(ByVal strTips)

  57.   Dim objFolder

  58.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)

  59.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path

  60. End Function

  61. 

  62. 

  63. ' 创建 Word 对象

  64. Function Word_Init()

  65.   Set objWord = CreateObject("Word.Application")

  66.   If Not Err.Number = 0 Then

  67.     Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。"

  68.     WScript.Quit(999)

  69.   End If

  70.   If Not objWord.Application.Version >= 12.0 Then

  71.     Msgbox "警告：请使用 Office 2007 以上版本。"

  72.   End If

  73.   ' 隐藏运行，屏蔽提示

  74.   objWord.Visible = False

  75.   objWord.DisplayAlerts = False

  76.   Set Word_Init = objWord

  77. End Function

  78. 

  79. 

  80. '将转换后的TXT追加到指定文件

  81. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)

  82.     Set fso = CreateObject("Scripting.FileSystemObject")

  83.     If Not fso.FileExists(strFilePath & ".txt") Then Exit Function

  84.     ' 整理路径

  85.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)

  86.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)

  87.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"

  88. 

  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. 

  102. ' 获取文件夹所有文件夹、文件列表(数组)

  103. Function ScanFolder(ByVal strPath)

  104.     Dim arr()

  105.     ReDim Preserve arr(0)

  106.     Call SCAN_FOLDER(arr, strPath)

  107.     ReDim Preserve arr(UBound(arr) - 1)

  108.     ScanFolder = arr

  109. End Function

  110. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)

  111.     On Error Resume Next

  112.     Dim fso, objItems, objFile, objFolder

  113.     Set fso = CreateObject("Scripting.FileSystemObject")

  114.     Set objItems = fso.GetFolder(folderSpec)

  115.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"

  116.     If (Not fso.FolderExists(folderSpec)) Then Exit Function

  117.     For Each objFile In objItems.Files

  118.         arr(UBound(arr)) = objFile.Path

  119.         ReDim Preserve arr(UBound(arr) + 1)

  120.     Next

  121.     For Each objFolder In objItems.subfolders

  122.         Call SCAN_FOLDER(arr, objFolder.Path)

  123.     Next

  124.     arr(UBound(arr)) = folderSpec

  125.     ReDim Preserve arr(UBound(arr) + 1)

  126. End Function

  127. 

  128. 

  129. ' 以命令提示符环境运行(保留参数)

  130. Sub CommandMode(ByVal sTitle)

  131.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then

  132.         Dim i, sArgs

  133.         For i = 1 To WScript.Arguments.Count

  134.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"

  135.         Next

  136.         CreateObject("WScript.Shell").Run( _

  137.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _

  138.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3

  139.             Wscript.Quit

  140.     End If

  141. 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  Ｙu２n＠qq.com"

  2. 

  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. 

  36. 

  37. ' 打开DOC，另存为

  38. Function Doc2Txt(objWord, FilePath)

  39.   On Error Resume Next

  40.   Set fso = CreateObject("Scripting.Filesystemobject")

  41.   If Not fso.FileExists(FilePath) Then Exit Function

  42.   

  43.   Const wdFormatText = 2

  44.   Const Encoding = 1200

  45.   Const wdCRLF = 0

  46.   Set objDoc = objWord.Documents.Open(FilePath)

  47.   

  48.   ' 另存为，wyx567反映个别Docx出错

  49.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _

  50.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF

  51.   

  52.   ' 获取Doc文本内容

  53.   strContent = objDoc.Content

  54.   strContent = Replace(strContent, vbCr, vbCrLf)

  55.   objDoc.Close False

  56.   

  57.   ' 保存Doc文本内容到txt文件

  58.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 8, True, -1)

  59.   wTxt.Write strContent

  60.   wTxt.Close

  61.   If Not Err.Number = 0 Then Doc2Txt = True

  62. End Function

  63. 

  64. 

  65. ' 浏览文件夹

  66. Function BrowseForFolder(ByVal strTips)

  67.   Dim objFolder

  68.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)

  69.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path

  70. End Function

  71. 

  72. 

  73. ' 创建 Word 对象

  74. Function Word_Init()

  75.   Set objWord = CreateObject("Word.Application")

  76.   If Not Err.Number = 0 Then

  77.     Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。"

  78.     WScript.Quit(999)

  79.   End If

  80.   If Not objWord.Application.Version >= 12.0 Then

  81.     Msgbox "警告：请使用 Office 2007 以上版本。"

  82.   End If

  83.   ' 隐藏运行，屏蔽提示

  84.   objWord.Visible = False

  85.   objWord.DisplayAlerts = False

  86.   Set Word_Init = objWord

  87. End Function

  88. 

  89. 

  90. '将转换后的TXT追加到指定文件

  91. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)

  92.     Set fso = CreateObject("Scripting.FileSystemObject")

  93.     If Not fso.FileExists(strFilePath & ".txt") Then Exit Function

  94.     ' 整理路径

  95.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)

  96.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)

  97.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"

  98. 

  99.     ' 打开转换后的TXT文件

  100.     Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)

  101.     strText = rTxt.ReadAll()

  102.     rTxt.Close

  103.     ' 删除转换后的文件

  104.     fso.DeleteFile strFilePath & ".txt", True

  105.     ' 将转换后的TXT追加到指定文件

  106.     Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)

  107.     wTxt.Write strText

  108.     wTxt.Close

  109. End Function

  110. 

  111. 

  112. ' 获取文件夹所有文件夹、文件列表(数组)

  113. Function ScanFolder(ByVal strPath)

  114.     Dim arr()

  115.     ReDim Preserve arr(0)

  116.     Call SCAN_FOLDER(arr, strPath)

  117.     ReDim Preserve arr(UBound(arr) - 1)

  118.     ScanFolder = arr

  119. End Function

  120. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)

  121.     On Error Resume Next

  122.     Dim fso, objItems, objFile, objFolder

  123.     Set fso = CreateObject("Scripting.FileSystemObject")

  124.     Set objItems = fso.GetFolder(folderSpec)

  125.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"

  126.     If (Not fso.FolderExists(folderSpec)) Then Exit Function

  127.     For Each objFile In objItems.Files

  128.         arr(UBound(arr)) = objFile.Path

  129.         ReDim Preserve arr(UBound(arr) + 1)

  130.     Next

  131.     For Each objFolder In objItems.subfolders

  132.         Call SCAN_FOLDER(arr, objFolder.Path)

  133.     Next

  134.     arr(UBound(arr)) = folderSpec

  135.     ReDim Preserve arr(UBound(arr) + 1)

  136. End Function

  137. 

  138. 

  139. ' 以命令提示符环境运行(保留参数)

  140. Sub CommandMode(ByVal sTitle)

  141.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then

  142.         Dim i, sArgs

  143.         For i = 1 To WScript.Arguments.Count

  144.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"

  145.         Next

  146.         CreateObject("WScript.Shell").Run( _

  147.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _

  148.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3

  149.             Wscript.Quit

  150.     End If

  151. 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  Ｙu２n＠qq.com"

  2. 

  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. 

  36. 

  37. ' 打开DOC，另存为

  38. Function Doc2Txt(objWord, FilePath)

  39.   On Error Resume Next

  40.   Set fso = CreateObject("Scripting.Filesystemobject")

  41.   If Not fso.FileExists(FilePath) Then Exit Function

  42.   

  43.   Const wdFormatText = 2

  44.   Const Encoding = 1200

  45.   Const wdCRLF = 0

  46.   Set objDoc = objWord.Documents.Open(FilePath)

  47.   

  48.   ' 另存为，wyx567反映个别Docx出错

  49.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _

  50.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF

  51.   

  52.   ' 获取Doc文本内容

  53.   strContent = objDoc.Content

  54.   objDoc.Close False

  55.   

  56.   ' 保存Doc文本内容到txt文件

  57.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 8, True, -1)

  58.   wTxt.Write FormatText(strContent)

  59.   wTxt.Close

  60.   If Not Err.Number = 0 Then Doc2Txt = True

  61. End Function

  62. 

  63. 

  64. ' 创建 Word 对象

  65. Function Word_Init()

  66.   Set objWord = CreateObject("Word.Application")

  67.   If Not Err.Number = 0 Then

  68.     Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。"

  69.     WScript.Quit(999)

  70.   End If

  71.   If Not objWord.Application.Version >= 12.0 Then

  72.     Msgbox "警告：请使用 Office 2007 以上版本。"

  73.   End If

  74.   ' 隐藏运行，屏蔽提示

  75.   objWord.Visible = False

  76.   objWord.DisplayAlerts = False

  77.   Set Word_Init = objWord

  78. End Function

  79. 

  80. 

  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. 

  90.     ' 打开转换后的TXT文件

  91.     Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)

  92.     strText = rTxt.ReadAll()

  93.     rTxt.Close

  94.     ' 删除转换后的文件

  95.     fso.DeleteFile strFilePath & ".txt", True

  96.     ' 将转换后的TXT追加到指定文件

  97.     Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)

  98.     wTxt.Write strText

  99.     wTxt.Close

  100. End Function

  101. 

  102. 

  103. ' 以命令提示符环境运行(保留参数)

  104. Sub CommandMode(ByVal sTitle)

  105.     If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then

  106.         Dim i, sArgs

  107.         For i = 1 To WScript.Arguments.Count

  108.             sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"

  109.         Next

  110.         CreateObject("WScript.Shell").Run( _

  111.             "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _

  112.             WScript.ScriptFullName & """ " & sArgs & " &pause"),3

  113.             Wscript.Quit

  114.     End If

  115. End Sub

  116. 

  117. 

  118. ' 格式化字符串

  119. Function FormatText(ByVal str)

  120. 	' 删除空行

  121. 	str = Replace(str, vbLf, "")

  122. 	str = Replace(str, vbCr, vbCrLf)

  123. 	str = regEx_replace("^\s*\r\n", str, "")

  124. 	' 取前300行

  125. 	arrStr = Split(str, vbCrLf)

  126. 	If UBound(arrStr)>(300-1) Then ReDim Preserve arrStr(300-1)

  127. 	str = Join(arrStr, vbCrLf)

  128. 	FormatText = str

  129. End Function

  130. 

  131. 

  132. ' 正则表达式替换

  133. Function regEx_replace(ByVal sPattern, ByVal str, ByVal sReplace)

  134. 	Dim regEx                      ' 建立变量。

  135.     Set regEx = CreateObject("VBScript.RegExp")  ' 建立正则表达式。

  136.         regEx.Pattern = sPattern   ' 设置模式。

  137.         regEx.IgnoreCase = True    ' 设置是否区分字符大小写。

  138.         regEx.Global = True        ' 设置全局可用性。

  139.         regEx.MultiLine = True     ' 多行匹配模式

  140. 	regEx_replace = regEx.Replace(str, sReplace)   ' 作替换。

  141. 	Set regEx = Nothing

  142. End Function

  143. 

  144. 

  145. ' 浏览文件夹

  146. Function BrowseForFolder(ByVal strTips)

  147.   Dim objFolder

  148.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)

  149.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path

  150. End Function

  151. 

  152. 

  153. ' 获取文件夹所有文件夹、文件列表(数组)

  154. Function ScanFolder(ByVal strPath)

  155.     Dim arr()

  156.     ReDim Preserve arr(0)

  157.     Call SCAN_FOLDER(arr, strPath)

  158.     ReDim Preserve arr(UBound(arr) - 1)

  159.     ScanFolder = arr

  160. End Function

  161. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)

  162.     On Error Resume Next

  163.     Dim fso, objItems, objFile, objFolder

  164.     Set fso = CreateObject("Scripting.FileSystemObject")

  165.     Set objItems = fso.GetFolder(folderSpec)

  166.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"

  167.     If (Not fso.FolderExists(folderSpec)) Then Exit Function

  168.     For Each objFile In objItems.Files

  169.         arr(UBound(arr)) = objFile.Path

  170.         ReDim Preserve arr(UBound(arr) + 1)

  171.     Next

  172.     For Each objFolder In objItems.subfolders

  173.         Call SCAN_FOLDER(arr, objFolder.Path)

  174.     Next

  175.     arr(UBound(arr)) = folderSpec

  176.     ReDim Preserve arr(UBound(arr) + 1)

  177. 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  Ｙu２n＠qq.com"

  2. 

  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. 

  36. 

  37. ' 打开DOC，另存为

  38. Function Doc2Txt(objWord, FilePath)

  39.   On Error Resume Next

  40.   Set fso = CreateObject("Scripting.Filesystemobject")

  41.   If Not fso.FileExists(FilePath) Then Exit Function

  42.   Set objDoc = objWord.Documents.Open(FilePath)

  43.   ' 方法一、另存为，wyx567反映个别Docx出错

  44.   ' Const wdFormatText = 2

  45.   ' Const Encoding = 1200

  46.   ' Const wdCRLF = 0

  47.   ' objWord.ActiveDocument.SaveAs FilePath & ".txt", wdFormatText, False, "", False, _

  48.   '      "", False, False, False, False, False, Encoding, False, False, wdCRLF

  49.   ' 方法二、直接获取Doc文本内容

  50.   strContent = objDoc.Content

  51.   objDoc.Close False

  52.   ' 保存Doc文本内容到txt文件

  53.   Set wTxt = fso.OpenTextFile(FilePath & ".txt", 2, True, -1)

  54.   wTxt.Write FormatText(strContent)

  55.   wTxt.Close

  56.   If Not Err.Number = 0 Then Doc2Txt = True

  57. End Function

  58. 

  59. 

  60. ' 创建 Word 对象

  61. Function Word_Init()

  62.   Const msoAutomationSecurityForceDisable = 3

  63.   Set objWord = CreateObject("Word.Application")

  64.   If Not Err.Number = 0 Then

  65.     Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。"

  66.     WScript.Quit(999)

  67.   End If

  68.   If Not objWord.Application.Version >= 12.0 Then

  69.     Msgbox "警告：请使用 Office 2007 以上版本。"

  70.   End If

  71.   ' 隐藏运行，屏蔽提示

  72.   objWord.Visible = False

  73.   objWord.DisplayAlerts = False

  74.   ' 禁用以编程方式打开的所有文件中的所有宏，而不显示任何安全警告。

  75.   ' VBA打开文件时（临时）禁用宏

  76.   ' http://club.excelhome.net/thread-1001802-1-1.html

  77.   objWord.AutomationSecurity = msoAutomationSecurityForceDisable

  78.   Set Word_Init = objWord

  79. End Function

  80. 

  81. 

  82. '将转换后的TXT追加到指定文件

  83. Function CreatTxtFile(ByVal strFolderPath, ByVal strFilePath)

  84.   Set fso = CreateObject("Scripting.FileSystemObject")

  85.   If Not fso.FileExists(strFilePath & ".txt") Then Exit Function

  86.     ' 整理路径

  87.     strSubFolderName = Mid(strFilePath, Len(strFolderPath) + 2)

  88.     If InStr(strSubFolderName, "\") > 0 Then

  89.     strSubFolderName = Left(strSubFolderName, InStr(strSubFolderName, "\") - 1)

  90.     strTxtFile = strFolderPath & "\" & strSubFolderName & "\" & strSubFolderName & ".txt"

  91.   Else

  92.     strTxtFile = strFolderPath & "\" & strSubFolderName & ".txt"

  93.   End If

  94.   ' 打开转换后的TXT文件

  95.   Set rTxt = fso.OpenTextFile(strFilePath & ".txt", 1, False, -1)

  96.   strText = rTxt.ReadAll()

  97.   rTxt.Close

  98.   ' 删除转换后的文件

  99.   fso.DeleteFile strFilePath & ".txt", True

  100.   ' 将转换后的TXT追加到指定文件

  101.   Set wTxt = fso.OpenTextFile(strTxtFile, 8, True, -1)

  102.   wTxt.Write strText

  103.   wTxt.Close

  104. End Function

  105. 

  106. 

  107. ' 以命令提示符环境运行(保留参数)

  108. Sub CommandMode(ByVal sTitle)

  109.   If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then

  110.     Dim i, sArgs

  111.     For i = 1 To WScript.Arguments.Count

  112.       sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"

  113.     Next

  114.     CreateObject("WScript.Shell").Run( _

  115.       "cmd /c Title " & sTitle & " &Cscript.exe //NoLogo  """ & _

  116.       WScript.ScriptFullName & """ " & sArgs & " &pause"),3

  117.       Wscript.Quit

  118.   End If

  119. End Sub

  120. 

  121. 

  122. ' 格式化字符串

  123. Function FormatText(ByVal str)

  124.   ' 删除空行

  125.   str = Replace(str, vbLf, "")

  126.   str = Replace(str, vbCr, vbCrLf)

  127.   str = regEx_replace("^\s*\r\n", str, "")

  128.   ' 取前300行

  129.   arrStr = Split(str, vbCrLf)

  130.   If UBound(arrStr)>(300-1) Then ReDim Preserve arrStr(300-1)

  131.   str = Join(arrStr, vbCrLf)

  132.   FormatText = str

  133. End Function

  134. 

  135. 

  136. ' 正则表达式替换

  137. Function regEx_replace(ByVal sPattern, ByVal str, ByVal sReplace)

  138.   Dim regEx                      ' 建立变量。

  139.   Set regEx = CreateObject("VBScript.RegExp")  ' 建立正则表达式。

  140.   regEx.Pattern = sPattern   ' 设置模式。

  141.   regEx.IgnoreCase = True    ' 设置是否区分字符大小写。

  142.   regEx.Global = True        ' 设置全局可用性。

  143.   regEx.MultiLine = True     ' 多行匹配模式

  144.   regEx_replace = regEx.Replace(str, sReplace)   ' 作替换。

  145.   Set regEx = Nothing

  146. End Function

  147. 

  148. 

  149. ' 浏览文件夹

  150. Function BrowseForFolder(ByVal strTips)

  151.   Dim objFolder

  152.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)

  153.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path

  154. End Function

  155. 

  156. 

  157. ' 获取文件夹所有文件夹、文件列表(数组)

  158. Function ScanFolder(ByVal strPath)

  159.   Dim arr()

  160.   ReDim Preserve arr(0)

  161.   Call SCAN_FOLDER(arr, strPath)

  162.   ReDim Preserve arr(UBound(arr) - 1)

  163.   ScanFolder = arr

  164. End Function

  165. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)

  166.   On Error Resume Next

  167.   Dim fso, objItems, objFile, objFolder

  168.   Set fso = CreateObject("Scripting.FileSystemObject")

  169.   Set objItems = fso.GetFolder(folderSpec)

  170.   If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"

  171.   If (Not fso.FolderExists(folderSpec)) Then Exit Function

  172.   For Each objFile In objItems.Files

  173.     arr(UBound(arr)) = objFile.Path

  174.     ReDim Preserve arr(UBound(arr) + 1)

  175.   Next

  176.   For Each objFolder In objItems.subfolders

  177.     Call SCAN_FOLDER(arr, objFolder.Path)

  178.   Next

  179.   arr(UBound(arr)) = folderSpec

  180.   ReDim Preserve arr(UBound(arr) + 1)

  181. End Function
复制代码
作者: g99    时间: 2014-12-28 22:16

回复 16# yu2n


    运行流畅，速度极快！



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