Deleting Header and Footer from multiple word files using VBA macro-CodePudding

I want to have a macro in a separate word file that delete both the header and the footer of multiple files in a folder.

what I would like to have but which is not necessary is to output the result in another folder (it could be a sub-folder)

'
' RemoveHeadAndFoot Macro
'
'
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document
Dim oSec As Section
Dim oHead As HeaderFooter
Dim oFoot As HeaderFooter
  
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
  Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False)
  With ActiveDocument.Sections(1)
        .Headers(wdHeaderFooterPrimary).Range.Delete
        .Footers(wdHeaderFooterPrimary).Range.Delete
        
    'remove personal information
     '.RemoveDocumentInformation (wdRDIDocumentProperties)
    'String variable for the output filenames
    ' strOutFile = strOutFold & Split(.Name, ".")(0)
    'Save and close the document
    '.SaveAs FileName:=strOutFile
   ' .Close
  End With
  strFile = Dir()
Wend
'Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub


Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function

This code creates an output folder with no file in it and the files are unchanged( both the header and the footer are still intact)

Please what am I doing wrong?

CodePudding user response：

More like this:

'...
While strFile <> ""
    Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, _
                                 AddTorecentFiles:=False, Visible:=False)
    With DocSrc
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete
        .Sections(1).Footers(wdHeaderFooterPrimary).Range.Delete
        
        .RemoveDocumentInformation wdRDIDocumentProperties
        
        strOutFile = strOutFold & Split(.Name, ".")(0) 'no extension?
        .SaveAs FileName:=strOutFile
        .Close
    End With      
    strFile = Dir()
Wend
'...