Option Explicit


Sub ExtractSummary()
'Graham Mayor - https://www.gmayor.com - Last updated - 25 Nov 2021
Const sStart As String = "System Safety Assessment Summary"
Const sEnd As String = "Hardware Considerations"

Dim oDoc As Document
Dim bStartFound As Boolean, bEndFound As Boolean
Dim oSource As Document
Dim oRng As Range, oRng2 As Range, oDocRng As Range
Dim lPara As Long, lStart As Long
Dim fDialog As FileDialog
Dim strPath As String, strFile As String

    If Documents.Count = 0 Then Documents.Add

    Set oDoc = ActiveDocument

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With

    strFile = Dir$(strPath & "*.docx")
    While strFile <> ""
        Set oSource = Documents.Open(strPath & strFile)
        Set oRng = oSource.Range
        For lPara = 1 To oRng.Paragraphs.Count
            If InStr(1, oRng.Paragraphs(lPara).Range.Text, sStart) > 0 Then
                If oRng.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                    oRng.Start = oRng.Paragraphs(lPara).Range.Start
                    lStart = lPara + 1
                    bStartFound = True
                    Exit For
                End If
            End If
        Next lPara

        If bStartFound = False Then GoTo Skip

        For lPara = lStart To oSource.Paragraphs.Count
            Set oRng2 = oSource.Paragraphs(lPara).Range
            If InStr(1, oRng2.Text, sEnd) > 0 Then
                oRng.End = oRng2.Start - 2
                bEndFound = True
            End If
        Next lPara

        If bEndFound = False Then GoTo Skip

        Set oDocRng = oDoc.Range
        If Len(oDocRng) > 1 Then
            oDocRng.Collapse 0
            oDocRng.InsertBreak wdPageBreak
            Set oDocRng = oDoc.Range
            oDocRng.Collapse 0
        End If
        oDocRng.Text = oSource.Name & vbCr
        oDocRng.Paragraphs(1).Range.Font.Size = 14
        oDocRng.Paragraphs(1).Range.Font.Bold = True
        oDocRng.Collapse 0
        oDocRng.FormattedText = oRng.FormattedText
Skip:
        oSource.Close SaveChanges:=wdDoNotSaveChanges
        strFile = Dir$()
    Wend
lbl_Exit:
    Set fDialog = Nothing
    Set oSource = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oDocRng = Nothing
    Exit Sub
End Sub