none
Keep the active document's headers/footers and export them to new document RRS feed

  • Question

  • The document that contains all the drawing notes available contains header/footers that need to be exported as well as the items that are checked.  Below is the current code that is working but the headers/footers do not appear in the new drw_notes.docx.  How do I get the headers/footers to export and appear exactly like they are in the drawing notes master file?  Existing code is below:

    'The main method
    Sub ExportCheckedItemsToNewFile()
        conf = MsgBox("It'll take some time to export checked items into a new file, do you want to continue?", vbYesNo, "Confirmation")
        If conf = vbNo Then
            Exit Sub
        End If
    
        Dim i%, j%, content$, newFileName$
        newFileName = "C:/Common/drw_notes.docx"
        
        'Determine if the new file exists, if it doesn't, create a new one
        If FileExists(newFileName) = False Then
            Set newWord = CreateObject("Word.Application")
            newWord.Visible = False
            Set newdoc = newWord.Documents.Add
            newdoc.SaveAs (newFileName)
            newdoc.Close
            newWord.Quit
        End If
        
        'Open the new file, prepare to export the checked items into it
        Set newWord = CreateObject("Word.Application")
        newWord.Visible = False
        Set newdoc = newWord.Documents.Open(newFileName)
        
        'Enumerate all the Checkbox content controls
        For i = 1 To ActiveDocument.ContentControls.Count
            If ActiveDocument.ContentControls(i).Type = wdContentControlCheckBox Then
                If ActiveDocument.ContentControls(i).Checked Then
                    
                    'Determine if this is the last Checkbox in the document
                    If i < ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.ContentControls(i + 1).Range.Start
                        content = ActiveDocument.Range(startRange, endRange).Text
                    ElseIf i = ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.Range.End
                        content = ActiveDocument.Range(startRange, endRange).Text
                    End If
                    j = j + 1
                    'Export the checked items into the new file
                    If content Like "FN*" Then
                        content = ReplaceFirstFoundString(content, "FN[0-9]+", "FN" & j)
                    ElseIf content Like "GN*" Then
                        content = ReplaceFirstFoundString(content, "GN[0-9]+", "GN" & j)
                    End If
                                    
                    newdoc.content.InsertAfter content & Chr(10)
                    newdoc.Save
    
                End If
            Else
                'Make sure there're no other type of content controls in the document
                MsgBox "There are Non-Checkbox content controls in this document."
            End If
        Next
                
        newdoc.Close
        newWord.Quit
        MsgBox "Complete! Please check file:" & newFileName
        ActiveDocument.Save
    End Sub

    Friday, February 7, 2014 6:34 PM

Answers

  • You could use code like the following, before the 'newdoc.Close' line:

    Dim Sctn As Section, HdFt As HeaderFooter
    With ActiveDocument
      For Each Sctn In .Sections
        For Each HdFt In Sctn.Headers
          With HdFt
            If .LinkToPrevious = False Then
              .Range.Copy
              With NewDoc.Sections(Sctn.Index).Headers(HdFt.Index)
              .LinkToPrevious = False
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              End With
            End If
          End With
        Next
        For Each HdFt In Sctn.Footers
          With HdFt
            If .LinkToPrevious = False Then
              .Range.Copy
              With NewDoc.Sections(Sctn.Index).Footers(HdFt.Index)
              .LinkToPrevious = False
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              End With
            End If
          End With
        Next
      Next
    End With
    Set NewDoc = Nothing

    Ideally, I'd prefer to declare the variables at the top of the code module, but they can be declared this late.

    Note: The code allows for the possibility that, having been populated, your newDoc will have multiple Sections containing header/footer content in any of the 3 header/footer ranges that each header/footer has.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Sunday, February 9, 2014 5:58 AM
  • Your code has:
    newFileName = "C:/Common/drw_notes.docx"
    ...

    Set NewDoc = newWord.Documents.Open(newFileName)
    and the code I posted references NewDoc and copies the header/footer content to it from the ActiveDocument.

    However, you may be having problems due to reliance on ActiveDocument, since you're not controlling which document that is - it could even be NewDoc. You should set a reference to ActiveDocument before opening NewDoc (e.g. Dim SrcDoc as Document ... Set SrcDoc = ActiveDocument) then use the SrcDoc and NewDoc references so as to ensure the correct document is being used at each step.


    Cheers
    Paul Edstein
    [MS MVP - Word]


    Wednesday, February 12, 2014 8:30 PM

All replies

  • You could use code like the following, before the 'newdoc.Close' line:

    Dim Sctn As Section, HdFt As HeaderFooter
    With ActiveDocument
      For Each Sctn In .Sections
        For Each HdFt In Sctn.Headers
          With HdFt
            If .LinkToPrevious = False Then
              .Range.Copy
              With NewDoc.Sections(Sctn.Index).Headers(HdFt.Index)
              .LinkToPrevious = False
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              End With
            End If
          End With
        Next
        For Each HdFt In Sctn.Footers
          With HdFt
            If .LinkToPrevious = False Then
              .Range.Copy
              With NewDoc.Sections(Sctn.Index).Footers(HdFt.Index)
              .LinkToPrevious = False
              .Range.PasteAndFormat (wdFormatOriginalFormatting)
              End With
            End If
          End With
        Next
      Next
    End With
    Set NewDoc = Nothing

    Ideally, I'd prefer to declare the variables at the top of the code module, but they can be declared this late.

    Note: The code allows for the possibility that, having been populated, your newDoc will have multiple Sections containing header/footer content in any of the 3 header/footer ranges that each header/footer has.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Sunday, February 9, 2014 5:58 AM
  • Paul, add this before which line of newdoc.close?

    Monday, February 10, 2014 3:07 PM
  • The second (last) one.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Monday, February 10, 2014 8:18 PM
  • Private Sub Document_Close()
        Call ExportCheckedItemsToNewFile
    End Sub
    
    'The main method
    Sub ExportCheckedItemsToNewFile()
        conf = MsgBox("It'll take some time to export checked items into a new file, do you want to continue?", vbYesNo, "Confirmation")
        If conf = vbNo Then
            Exit Sub
        End If
    
        Dim i%, j%, content$, newFileName$
        newFileName = "C:/Common/drw_notes.docx"
        
        'Determine if the new file exists, if it doesn't, create a new one
        If FileExists(newFileName) = False Then
            Set newWord = CreateObject("Word.Application")
            newWord.Visible = False
            Set NewDoc = newWord.Documents.Add
            NewDoc.SaveAs (newFileName)
            NewDoc.Close
            newWord.Quit
        End If
        
        'Open the new file, prepare to export the checked items into it
        Set newWord = CreateObject("Word.Application")
        newWord.Visible = False
        Set NewDoc = newWord.Documents.Open(newFileName)
        
        'Enumerate all the Checkbox content controls
        For i = 1 To ActiveDocument.ContentControls.Count
            If ActiveDocument.ContentControls(i).Type = wdContentControlCheckBox Then
                If ActiveDocument.ContentControls(i).Checked Then
                    
                    'Determine if this is the last Checkbox in the document
                    If i < ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.ContentControls(i + 1).Range.Start
                        content = ActiveDocument.Range(startRange, endRange).Text
                    ElseIf i = ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.Range.End
                        content = ActiveDocument.Range(startRange, endRange).Text
                    End If
                    j = j + 1
                    'Export the checked items into the new file
                    If content Like "FN*" Then
                        content = ReplaceFirstFoundString(content, "FN[0-9]+", "FN" & j)
                    ElseIf content Like "GN*" Then
                        content = ReplaceFirstFoundString(content, "GN[0-9]+", "GN" & j)
                    End If
                                                     
                    NewDoc.content.InsertAfter content & Chr(10)
                     Dim Sctn As Section, HdFt As HeaderFooter
                        With ActiveDocument
                          For Each Sctn In .Sections
                            For Each HdFt In Sctn.Headers
                              With HdFt
                                If .LinkToPrevious = False Then
                                  .Range.Copy
                                  With NewDoc.Sections(Sctn.Index).Headers(HdFt.Index)
                                  .LinkToPrevious = False
                                  .Range.PasteAndFormat (wdFormatOriginalFormatting)
                                  End With
                                End If
                              End With
                            Next
                            For Each HdFt In Sctn.Footers
                              With HdFt
                                If .LinkToPrevious = False Then
                                  .Range.Copy
                                  With NewDoc.Sections(Sctn.Index).Footers(HdFt.Index)
                                  .LinkToPrevious = False
                                  .Range.PasteAndFormat (wdFormatOriginalFormatting)
                                  End With
                                End If
                              End With
                            Next
                          Next
                        End With
                        Set NewDoc = Nothing
                    NewDoc.Save
    
                End If
            Else
                'Make sure there're no other type of content controls in the document
                MsgBox "There are Non-Checkbox content controls in this document."
            End If
        Next
                
        NewDoc.Close
        newWord.Quit
        MsgBox "Complete! Please check file:" & newFileName
        ActiveDocument.Save
    End Sub
    
    'Check if a file exists
    Private Function FileExists(filename As String) As Boolean
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filename) Then FileExists = True Else FileExists = False
    End Function
    
    'Use regular expression to replace a found string to another string
    Private Function ReplaceFirstFoundString(srcString As String, pattern As String, replaceString As String) As String
        Set objRegEx = CreateObject("vbscript.regexp")
        objRegEx.Global = True
        objRegEx.IgnoreCase = True
        objRegEx.MultiLine = True
        objRegEx.pattern = pattern
        
        ReplaceFirstFoundString = objRegEx.Replace(srcString, replaceString)
    End Function
    This doesn't work for me. I get an error.
    Tuesday, February 11, 2014 7:59 PM
  • You need to have 'Set NewDoc = Nothing' after 'NewDoc.Close'.

    Cheers
    Paul Edstein
    [MS MVP - Word]


    • Edited by macropodMVP Tuesday, February 11, 2014 9:30 PM
    Tuesday, February 11, 2014 9:30 PM
  • The code is working like before but on the new file (drw_notes.docx) the headers and footers do not appear.  Do I need to call out the specific file drw_notes.docx somewhere in the code?

    'The main method
    Sub ExportCheckedItemsToNewFile()
        conf = MsgBox("It'll take some time to export checked items into a new file, do you want to continue?", vbYesNo, "Confirmation")
        If conf = vbNo Then
            Exit Sub
        End If
    
        Dim i%, j%, content$, newFileName$
        newFileName = "C:/Common/drw_notes.docx"
        
        'Determine if the new file exists, if it doesn't, create a new one
        If FileExists(newFileName) = False Then
            Set newWord = CreateObject("Word.Application")
            newWord.Visible = False
            Set NewDoc = newWord.Documents.Add
            NewDoc.SaveAs (newFileName)
            NewDoc.Close
            newWord.Quit
        End If
        
        'Open the new file, prepare to export the checked items into it
        Set newWord = CreateObject("Word.Application")
        newWord.Visible = False
        Set NewDoc = newWord.Documents.Open(newFileName)
        
        'Enumerate all the Checkbox content controls
        For i = 1 To ActiveDocument.ContentControls.Count
            If ActiveDocument.ContentControls(i).Type = wdContentControlCheckBox Then
                If ActiveDocument.ContentControls(i).Checked Then
                    
                    'Determine if this is the last Checkbox in the document
                    If i < ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.ContentControls(i + 1).Range.Start
                        content = ActiveDocument.Range(startRange, endRange).Text
                    ElseIf i = ActiveDocument.ContentControls.Count Then
                        startRange = ActiveDocument.ContentControls(i).Range.End
                        endRange = ActiveDocument.Range.End
                        content = ActiveDocument.Range(startRange, endRange).Text
                    End If
                    j = j + 1
                    'Export the checked items into the new file
                    If content Like "FN*" Then
                        content = ReplaceFirstFoundString(content, "FN[0-9]+", "FN" & j)
                    ElseIf content Like "GN*" Then
                        content = ReplaceFirstFoundString(content, "GN[0-9]+", "GN" & j)
                    End If
                        Dim Sctn As Section, HdFt As HeaderFooter
                        With ActiveDocument
                          For Each Sctn In .Sections
                            For Each HdFt In Sctn.Headers
                              With HdFt
                                If .LinkToPrevious = False Then
                                  .Range.Copy
                                  With NewDoc.Sections(Sctn.Index).Headers(HdFt.Index)
                                  .LinkToPrevious = False
                                  .Range.PasteAndFormat (wdFormatOriginalFormatting)
                                  End With
                                End If
                              End With
                            Next
                            For Each HdFt In Sctn.Footers
                              With HdFt
                                If .LinkToPrevious = False Then
                                  .Range.Copy
                                  With NewDoc.Sections(Sctn.Index).Footers(HdFt.Index)
                                  .LinkToPrevious = False
                                  .Range.PasteAndFormat (wdFormatOriginalFormatting)
                                  End With
                                End If
                              End With
                            Next
                          Next
                        End With
                    NewDoc.content.InsertAfter content & Chr(10)
                    NewDoc.Save
                   End If
            Else
                'Make sure there're no other type of content controls in the document
                MsgBox "There are Non-Checkbox content controls in this document."
            End If
        Next
                
        NewDoc.Close
        Set NewDoc = Nothing
        newWord.Quit
        MsgBox "Complete! Please check file:" & newFileName
        ActiveDocument.Save
    End Sub

    Wednesday, February 12, 2014 3:17 PM
  • Your code has:
    newFileName = "C:/Common/drw_notes.docx"
    ...

    Set NewDoc = newWord.Documents.Open(newFileName)
    and the code I posted references NewDoc and copies the header/footer content to it from the ActiveDocument.

    However, you may be having problems due to reliance on ActiveDocument, since you're not controlling which document that is - it could even be NewDoc. You should set a reference to ActiveDocument before opening NewDoc (e.g. Dim SrcDoc as Document ... Set SrcDoc = ActiveDocument) then use the SrcDoc and NewDoc references so as to ensure the correct document is being used at each step.


    Cheers
    Paul Edstein
    [MS MVP - Word]


    Wednesday, February 12, 2014 8:30 PM