代码1（WORD中VBA运行成功，无法指定存哪个文件夹，下面改）：
Sub ConvertDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.SaveAs FileName:=strFolder & "\" & Split(strFile, ".doc")(0) & ".txt", FileFormat:=wdFormatText, AddToRecentFiles:=False, Encoding:=msoEncodingUTF8
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择包含要处理的 Word 文档的文件夹：", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
需要注意的是：
如果你需要处理的 Word 文档后缀为 .docx 而不是 .doc，那么需要将代码中的所有 .doc（共两处）手动替换成 .docx
2. 如果你希望修改生成的 txt 文件的编码格式（默认是 UTF8），那么需要将代码中的 msoEncodingUTF8 手动替换为你想要的编码对应的名称，如 msoEncodingSimplifiedChineseGBK 和 msoEncodingSimplifiedChineseGB18030 等。相关信息可以在官方文档中查询。
方法2（以下代码在word中运行成功，处理后的TXT指定存储路径为E盘“999”的文件夹中）：
Sub ConvertDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
.SaveAs FileName:="E:\999\" & Split(Mid(strFile, InStrRev(strFile, "\") + 1), ".doc")(0) & ".txt", FileFormat:=wdFormatText, AddToRecentFiles:=False, Encoding:=msoEncodingUTF8
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择包含要处理的 Word 文档的文件夹：", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
更新代码（支持递归处理所选取文件夹下的所有子文件夹中的文档）：
Sub ConvertDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFiles As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
Debug.Print strFolder
If strFolder = "" Then Exit Sub
strFiles = LoopThroughFiles(strFolder, ".doc", True)
Dim iFiles() As String
iFiles() = Split(strFiles, vbTab)
Dim i As Long
For i = LBound(iFiles) To UBound(iFiles)
If iFiles(i) <> "" And iFiles(i) <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=iFiles(i), AddToRecentFiles:=False, Visible:=False)
With wdDoc
.SaveAs FileName:=Split(iFiles(i), ".doc")(0) & ".txt", FileFormat:=wdFormatText, AddToRecentFiles:=False, Encoding:=msoEncodingUTF8
.Close SaveChanges:=True
End With
End If
Next i
Set wdDoc = Nothing
Application.ScreenUpdating = True
MsgBox "已转换" & UBound(iFiles) & "个文档"
End Sub
Private Function LoopThroughFiles(inputDirectory As String, filenameCriteria As String, doTraverse As Boolean) As String
Dim tmpOut As String
Dim StrFile As String
If doTraverse = True Then
Dim allFolders As String
Dim iFolders() As String
allFolders = TraverseDir(inputDirectory & "\", 1, 100)
iFolders() = Split(allFolders, vbTab)
tmpOut = LoopThroughFiles(inputDirectory, filenameCriteria, False)
Dim j As Long
For j = LBound(iFolders) To UBound(iFolders)
If iFolders(j) <> "" Then
StrFile = LoopThroughFiles(iFolders(j), filenameCriteria, False)
tmpOut = tmpOut & vbTab & StrFile
End If
Next j
LoopThroughFiles = tmpOut
Else
'https://stackoverflow.com/a/45749626/4650297
StrFile = Dir(inputDirectory & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
tmpOut = tmpOut & vbTab & inputDirectory & "\" & StrFile
StrFile = Dir()
Loop
LoopThroughFiles = tmpOut
End If
End Function
Private Function TraverseDir(path As String, depth As Long, maxDepth As Long) As String
'https://analystcave.com/vba-dir-function-how-to-traverse-directories/#Traversing_directories
If depth > maxDepth Then
TraverseDir = ""
Exit Function
End If
Dim currentPath As String, directory As Variant
Dim dirCollection As Collection
Set dirCollection = New Collection
Dim dirString As String
currentPath = Dir(path, vbDirectory)
'Explore current directory
Do Until currentPath = vbNullString
' Debug.Print currentPath
If Left(currentPath, 1) <> "." And (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
dirString = dirString & vbTab & path & currentPath
dirCollection.Add currentPath
End If
currentPath = Dir()
Loop
TraverseDir = dirString
'Explore subsequent directories
For Each directory In dirCollection
TraverseDir = TraverseDir & vbTab & TraverseDir(path & directory & "\", depth + 1, maxDepth)
Next directory
End Function
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择包含要处理的 Word 文档的文件夹：", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.path
Set oFolder = Nothing
End Function
发表评论