Option Explicit On

Module Cmt
    'Private App As Word.Application
    Public Function AddColor(sType As String) As Boolean
        'Highlight the current selection in a manner which identifies what the selection is
        Dim bReturn As Boolean

        bReturn = True  'default return value
        With App.Selection.Range
            App.Selection.Font.Color = Word.WdColor.wdColorBlack
            If UCase(sType) Like "STEP*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
            ElseIf UCase(sType) Like "NOTES*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdAuto
            ElseIf UCase(sType) Like "NOTE*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
            ElseIf UCase(sType) Like "CAUTIONS*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdAuto
            ElseIf UCase(sType) Like "CAUTION*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdBrightGreen
            ElseIf UCase(sType) Like "IGNORE" Then
                .HighlightColorIndex = Word.WdColorIndex.wdGray50
            ElseIf UCase(sType) Like "SECTION*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdRed
            ElseIf UCase(sType) Like "FIGURE*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdYellow
            ElseIf UCase(sType) Like "EQUATION*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdYellow
            ElseIf UCase(sType) Like "TABLE*" Then
                .HighlightColorIndex = Word.WdColorIndex.wdYellow
            Else
                'don't know what this is so return false
                bReturn = False
            End If
        End With

        AddColor = bReturn

    End Function

    Public Function GetCmtValue(Cmt As Word.Comment, sParam As String) As String
        Dim sReturn As String

        sReturn = ""

        If Not Cmt Is Nothing Then
            With Cmt.Range
                If UCase(Cmt.Author) Like "STEP*" Then
                    Select Case LCase(sParam)
                        Case "level"
                            sReturn = Right(Cmt.Author, 1)
                        Case "style"
                            sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                        Case "checkoff"
                            sReturn = Replace(.Paragraphs(4).Range.Text, Chr(13), "")
                    End Select
                Else
                    Select Case UCase(Cmt.Author)
                        Case "SECTION"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
                                Case "type"
                                    sReturn = Replace(.Paragraphs(3).Range.Text, Chr(13), "")
                                Case "number"
                                    sReturn = Replace(.Paragraphs(4).Range.Text, Chr(13), "")
                                Case "title"
                                    sReturn = Replace(.Paragraphs(5).Range.Text, Chr(13), "")
                                Case "id"
                                    sReturn = Replace(.Paragraphs(6).Range.Text, Chr(13), "")
                            End Select
                        Case "CAUTION"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                            End Select
                        Case "NOTE"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                            End Select
                        Case "TABLE"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                            End Select
                        Case "FIGURE"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                            End Select
                        Case "EQUATION"
                            Select Case LCase(sParam)
                                Case "style"
                                    sReturn = .Paragraphs(2).Range.Text & " " & .Paragraphs(1).Range.Text
                            End Select
                    End Select
                End If
            End With
        End If

        GetCmtValue = sReturn

    End Function

    Public Sub ModifyComment(ByRef Cmt As Word.Comment, ByVal sMsg As String)
        Dim rng As Word.Range
        Dim sAuthor As String

        sAuthor = Cmt.Author
        Cmt.Scope.Select()
        Cmt.Delete()

        With App.Selection
            rng = .Range
            Cmt = App.ActiveDocument.Comments.Add(Range:= .Range, Text:=sMsg)
            Cmt.Author = sAuthor
            rng.Select()
        End With

    End Sub

    Public Sub MoveComment(ByVal CmtType As String, ByVal Direction As String)
        Dim bMoved As Boolean
        Dim sAuthor As String
        Dim sMsg As String
        Dim sScope As String
        Dim Cmt As Word.Comment
        Dim rng As Word.Range
        Dim lColor As Long
        Dim lHighlight As Long

        If App.Selection.Comments.Count > 0 Then
            Cmt = App.Selection.Comments(1)
            sAuthor = Cmt.Author
            If InStr(sAuthor, CmtType) > 0 Then
                sMsg = Cmt.Range.Text
                rng = Cmt.Scope
                lColor = rng.Font.Color
                lHighlight = rng.HighlightColorIndex

                If Not rng.Font.Italic = False Then
                    'make sure to capture the entire paragraph
                    sScope = rng.Text
                    rng.Expand(Unit:=Word.WdUnits.wdParagraph)
                    'delete original comment
                    Cmt.Delete()
                    rng.Delete()
                    'position range to new location and add paragraph
                    If LCase(Direction) = "up" Then
                        rng.Move(Unit:=Word.WdUnits.wdParagraph, Count:=-1)
                        rng.InsertParagraphBefore()
                        rng = rng.Paragraphs.First.Range
                    Else
                        rng.Move(Unit:=Word.WdUnits.wdParagraph, Count:=1)
                        rng.InsertParagraphAfter()
                        rng = rng.Paragraphs.Last.Range
                    End If
                    'fill new paraagraph with original comment scope
                    rng.ParagraphFormat.Style = App.ActiveDocument.Styles("Normal").NameLocal
                    rng.InsertBefore(sScope)
                    rng.Font.Italic = True
                    'attach comment to new paragraph
                    Cmt = App.ActiveDocument.Comments.Add(Range:=rng, Text:=sMsg)
                    Cmt.Author = sAuthor
                    rng.Font.Color = lColor
                    rng.HighlightColorIndex = lHighlight
                    rng.Select()
                Else
                    If LCase(Direction) = "up" Then
                        bMoved = MovePrevious
                    Else
                        bMoved = MoveNext
                    End If

                    If bMoved = True Then
                        rng.Font.Color = Word.WdColor.wdColorAutomatic
                        rng.HighlightColorIndex = Word.WdColorIndex.wdAuto
                        rng = App.Selection.Range
                        Cmt.Delete()
                        Cmt = App.ActiveDocument.Comments.Add(Range:=rng, Text:=sMsg)
                        Cmt.Author = sAuthor
                        rng.Font.Color = lColor
                        rng.HighlightColorIndex = lHighlight
                        rng.Select()
                    End If
                End If
            End If
        End If
    End Sub

    Public Function GetComment(rng As Word.Range) As Word.Range
        'returns the content of the first comment
        'associated with the range provided
        Dim rReturn As Word.Range
        Dim r As Word.Range
        Dim Cmt As Word.Comment

        rReturn = Nothing
        If rng.Information(Word.WdInformation.wdInCommentPane) = True Then
            rReturn = rng.Comments(1).Range
        Else
            r = App.ActiveDocument.Range(rng.Start, rng.Start)
            For Each Cmt In App.ActiveDocument.Comments
                If r.InRange(Cmt.Scope) Then
                    rReturn = Cmt.Range
                    Exit For
                End If
            Next Cmt
        End If

        GetComment = rReturn

    End Function

    Public Function GoToComment(Optional LimitToPara As Boolean = True) As Boolean
        'move selection to comment associated with current selection
        'return true if selection is in comment
        Dim rng As Word.Range
        Dim bReturn As Boolean

        If App.Selection.Information(Word.WdInformation.wdInCommentPane) = False Then
            bReturn = False
            rng = GetComment(App.Selection.Range)
            If Not rng Is Nothing Then
                rng.Select()
                bReturn = True
            End If
        Else
            bReturn = True
        End If

        GoToComment = bReturn

    End Function

    Public Function MoveToNextComment(Optional sAuthor As String = "") As Word.Comment
        Dim rng As Word.Range
        Dim Cmt As Word.Comment
        Dim cReturn As Word.Comment
        Dim bSelectCmt As Boolean
        Dim I As Integer

        cReturn = Nothing

        If sAuthor <> "" Then
            If App.Selection.Comments.Count > 0 Then
                Cmt = App.Selection.Comments(1)
                sAuthor = Cmt.Author
            End If
        End If

        If App.Selection.Information(Word.WdInformation.wdInCommentPane) Then
            bSelectCmt = True
            App.Selection.Comments(1).Scope.Select()
        Else
            bSelectCmt = False
        End If

        If App.Selection.End < App.ActiveDocument.Content.End Then
            rng = App.ActiveDocument.Range(App.Selection.End, App.ActiveDocument.Content.End)
            With rng.Paragraphs
                For I = 1 To .Count
                    If .Item(I).Range.Comments.Count > 0 Then
                        Cmt = .Item(I).Range.Comments(1)
                        If (sAuthor = Cmt.Author) Or (sAuthor = "") Then
                            If bSelectCmt = True Then
                                Cmt.Range.Select()
                            Else
                                Cmt.Scope.Select()
                            End If
                            cReturn = Cmt
                            Exit For
                        End If
                    End If
                Next I
            End With
        End If

        MoveToNextComment = cReturn

    End Function

    Public Sub InsertComment(ByVal sAuthor As String, Optional sMsg As String = "")
        Dim Cmt As Word.Comment
        Dim rng As Word.Range

        On Error GoTo Err_InsertComment
        RemoveComments()
        sAuthor = Trim(sAuthor)
        If AddColor(sAuthor) = True Then
            With App.Selection
                rng = .Range
                Cmt = App.ActiveDocument.Comments.Add(Range:= .Range, Text:=sMsg)
                Cmt.Author = sAuthor
            End With
            rng.Select
        End If

Bye_InsertComment:
        Exit Sub

Err_InsertComment:
        Err.Clear()
        Resume Bye_InsertComment

    End Sub

    Public Sub RemoveComments(Optional ByVal AskFirst As Boolean = False, Optional CmtType As String = "")
        Dim rng As Word.Range
        Dim rStart As Word.Range
        Dim rEnd As Word.Range
        Dim Cmt As Word.Comment
        Dim sMsg As String
        Dim I As Integer

        If App.Selection.Information(Word.WdInformation.wdInCommentPane) = True Then
            Cmt = App.Selection.Comments(1)
            If CmtType <> "" Then
                If Cmt.Author Like CmtType & "*" Then
                    Cmt.Scope.Select()
                    DeleteComment(Cmt)
                End If
            Else
                Cmt.Scope.Select()
                DeleteComment(Cmt)
            End If
        Else
            If AskFirst = True Then
                If App.Selection.Range.Paragraphs.Count > 1 Then
                    sMsg = "Do you wish to delete all Comments within the current selection?"
                    If MsgBox(sMsg, vbYesNo + vbQuestion + vbDefaultButton1, "Remove Comments") = vbYes Then
                        AskFirst = False
                    End If
                Else
                    AskFirst = False
                End If
            End If
            If AskFirst = False Then
                With App.Selection
                    rng = .Range
                    .MoveEndWhile(Cset:=Chr(13), Count:=Word.WdConstants.wdBackward)
                    If .Information(Word.WdInformation.wdWithInTable) Then
                        .End = .End - 1
                    End If
                    'locate start and end points of the selection
                    rStart = App.ActiveDocument.Range(.Start, .Start)
                    rEnd = App.ActiveDocument.Range(.End, .End)
                End With

                For I = App.ActiveDocument.Comments.Count To 1 Step -1
                    Cmt = App.ActiveDocument.Comments(I)
                    If Cmt.Scope.InRange(rng) Or rng.InRange(Cmt.Scope) Or rStart.InRange(Cmt.Scope) Or rEnd.InRange(Cmt.Scope) Then
                        If CmtType <> "" Then
                            If Cmt.Author Like CmtType & "*" Then
                                DeleteComment(Cmt)
                            End If
                        Else
                            DeleteComment(Cmt)
                        End If
                    End If
                Next I
                rng.Select
            End If
        End If

    End Sub

    Public Sub DeleteComment(ByRef Cmt As Word.Comment)
        Dim rng As Word.Range
        Dim I As Integer

        rng = Cmt.Scope
        Cmt.Delete()

        With rng
            If Not .Font.Italic = False Then
                For I = .Paragraphs.Count To 1 Step -1
                    .Paragraphs(I).Range.Delete
                Next I
            Else
                For I = .Paragraphs.Count To 1 Step -1
                    .Paragraphs(I).Range.Font.ColorIndex = Word.WdColorIndex.wdAuto
                    .Paragraphs(I).Range.HighlightColorIndex = Word.WdColorIndex.wdAuto
                Next I
            End If
        End With

    End Sub

End Module