word文件docx批量转为TXT文本文件

代码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

需要注意的是：

1. 如果你需要处理的 Word 文档后缀为 .docx 而不是 .doc，那么需要将代码中的所有 .doc（共两处）手动替换成 .docx

2. 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