Sub ExtractCommentsForReadAloud()
    ' Updated 2021-05-27
    '
    ' Based on the macro ExtractCommentsToNewDoc
    ' by Lene Fredborg, DocTools - www.thedoctools.com
    '
    ' Hard breaks within comments are replaced with soft breaks for formatting.
    ' URLS are replaced with anonymized titles to  to facilitate reading.
    ' Page numbers reflect the pagination with tracked changes not visible.
    '
    ' This macro uses  the subroutine ClearFindAndReplaceParameters, which must be present for it to work properly.
    '
    ' Adapted by Michael Schuler (https://bergerplusschuler.com)

    Dim oDoc As Document
    Dim oNewDoc As Document
    Dim lCount As Long
    Dim sComment As String
    Dim lLoop As Long
    Const sDialogTitle As String = "Extract Comments For Read Aloud"
        
    On Error GoTo Err_Msg
    
    Set oDoc = ActiveDocument
    lCount = ActiveDocument.Comments.Count
    If lCount = 0 Then
        MsgBox "The active document contains no comments.", vbInformation, sDialogTitle
        GoTo Macroend
        Else
            If MsgBox("Do  you want to extract " & lCount & " comments to a new document?", vbYesNo + vbQuestion, sDialogTitle) <> vbYes Then
                GoTo Macroend
            End If
    End If
    
    Application.ScreenUpdating = False
    Set oNewDoc = Documents.add
    oNewDoc.PageSetup.Orientation = wdOrientPortrait
    oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
        "Comments extracted from: " & oDoc.FullName & vbCr & _
        "Created by: " & Application.UserName & vbCr & _
        "Creation date: " & Format(Date, "MMMM d, yyyy")
    With oNewDoc.Styles(wdStyleNormal)
        .Font.Name = "Arial"
        .Font.size = 10
        .ParagraphFormat.LeftIndent = InchesToPoints(1)
        .ParagraphFormat.SpaceAfter = 6
        .ParagraphFormat.FirstLineIndent = InchesToPoints(-1)
    End With
    With oNewDoc.Styles(wdStyleHeader)
        .Font.size = 8
        .ParagraphFormat.SpaceAfter = 0
    End With
    WordBasic.StartOfDocument
    For lLoop = 1 To lCount
        sComment = Replace(oDoc.Comments(lLoop).Range.Text, Chr(13), Chr(11))
        Selection.InsertAfter "Page " & oDoc.Comments(lLoop).Scope.Information(wdActiveEndPageNumber) & vbTab & sComment & vbCr
        DoEvents
    Next lLoop
    Selection.WholeStory
    Selection.Style = ActiveDocument.Styles("Normal")

    'replace URLs with anonymized hyperlinks
    Options.AutoFormatReplaceHyperlinks = True
    oNewDoc.Select
    Selection.Range.AutoFormat
    Selection.Collapse
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "<http[!^032]{1,}"
        .Replacement.Text = "[URL Replaced]"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Application.ScreenUpdating = True
    
    oNewDoc.Activate
    MsgBox lCount & " comments have been found and the comments document is ready for use.", vbInformation, sDialogTitle
    Call ClearFindAndReplaceParameters
    
Macroend:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
Exit Sub

Err_Msg:
    MsgBox "The macro has encountered an error." & vbCrLf & Err.Number & ": " & Err.description, vbCritical, sDialogTitle

End Sub

Private Sub ClearFindAndReplaceParameters()

    'from https://wordmvp.com/FAQs/MacrosVBA/ClearFind.htm
    'can be run from any search to reset the search parameters

    With Selection.Find
       .ClearFormatting
       .Replacement.ClearFormatting
       .Text = ""
       .Replacement.Text = ""
       .Forward = True
       .Wrap = wdFindStop
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
    End With

End Sub