How to convert a WORD file to .txt with different header? - vba

Question

I have got a lot of word file (~5000) with different header what i read with a macro and merge these multiple word document placed in a folder into one document.
Here the relevant code:
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
It is working, but when I am trying to save file as .txt, the header+footer lose..is it any way which one I can save this header part to a .txt file too? (as I wrote, in every document has got different header.)
EDIT:
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

This is not fully tested but should get you going.
I have only altered your Do loop. Replace, try out and have fun:
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