如何将 WORD 文件转换为具有不同标题的 .txt？

Question

我有很多带有不同标题的 word 文件 (~5000)，我用宏读取了这些文件，并将这些放在文件夹中的多个 word 文档合并到一个文档中。

这里是相关代码：

Sub MergeDocs() 
    Dim rng As Range 
    Dim MainDoc As Document 
    Dim strFile As String, strFolder As String 
    Dim Count As Long 
    With Application.FileDialog(msoFileDialogFolderPicker) 
        .Title = "Pick folder" 
        .AllowMultiSelect = False 
        If .Show Then 
            strFolder = .SelectedItems(1) & Application.PathSeparator 
        Else 
            Exit Sub 
        End If 
    End With 
    Set MainDoc = Documents.Add 
    strFile = Dir$(strFolder & "*.doc") ' can change to .docx
    Count = 0 
    Do Until strFile = "" 
        Count = Count + 1 
        Set rng = MainDoc.Range 
        With rng 
            .Collapse wdCollapseEnd 
            If Count > 1 Then 
                .InsertBreak wdSectionBreakNextPage 
                .End = MainDoc.Range.End 
                .Collapse wdCollapseEnd 
            End If 
            .InsertFile strFolder & strFile 
        End With 
        strFile = Dir$() 
    Loop 
    MsgBox ("Files are merged") 
lbl_Exit: 
    Exit Sub 
End Sub 

它正在工作，但是当我尝试将文件另存为 .txt 时，页眉+页脚丢失了。有什么方法可以将此页眉部分也保存到 .txt 文件中吗？ （正如我所写，每个文档都有不同的标题。）

编辑：

Sub MergeDocs()
    Dim rng As Range
    Dim MainDoc As Document
    Dim strFile As String, strFolder As String
    Dim Count As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Pick folder"
        .AllowMultiSelect = False
        If .Show Then
            strFolder = .SelectedItems(1) & Application.PathSeparator
        Else
            Exit Sub
        End If
    End With
    Set MainDoc = Documents.Add
    strFile = Dir$(strFolder & "*.doc") ' can change to .docx
    Count = 0
    Dim doc As Document
    Dim head As String, foot As String

    Do Until strFile = ""
        Set doc = Documents.Open(strFile)
        head = doc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text
        foot = doc.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
        doc.Close False

        Count = Count + 1
        Set rng = MainDoc.Range
        With rng
            .Collapse wdCollapseEnd
            If Count > 1 Then
                .InsertBreak wdSectionBreakNextPage
                .End = MainDoc.Range.End
                .Collapse wdCollapseEnd
        End If
        .InsertAfter head
        .InsertParagraphAfter
        .InsertFile strFolder & strFile
        .InsertAfter foot
    End With
    strFile = Dir$()
Loop
    MsgBox ("Files are merged")
lbl_Exit:
    Exit Sub
End Sub

Answer 1

这尚未经过全面测试，但应该可以帮助您。

我只改变了你的 Do 循环。替换，尝试并玩得开心：

Dim doc As Document
Dim head As String, foot As String

Do Until strFile = ""
    Set doc = Documents.Open(strFolder & strFile)
    head = doc.Sections(1).Headers(wdHeaderFooterPrimary).Range.text
    foot = doc.Sections(1).Footers(wdHeaderFooterPrimary).Range.text
    doc.Close False

    Count = Count + 1
    Set rng = MainDoc.Range
    With rng
        .Collapse wdCollapseEnd
        If Count > 1 Then
            .InsertBreak wdSectionBreakNextPage
            .End = MainDoc.Range.End
            .Collapse wdCollapseEnd
        End If
        .InsertAfter head
        .InsertParagraphAfter
        .InsertFile strFolder & strFile
        .InsertAfter foot
    End With
    strFile = Dir$()
Loop