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

Posted 2021-05-01

我有很多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

答案

这还没有经过全面测试，但应该让你去。

我只改变了你的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