Sub CommentAdd()
' Paul Beverley - Version 22.10.25
' Adds a comment, quoting the selected text

attachToWord = True
' If False, it attaches to the current sentence

useSingleQuotes = True
' If False, it uses double quotes

copySelectedText = True

preText = "Before text: "
postText = " After text"
preText = ""
postText = ""

addPageNum1 = False
addLineNum1 = False

addHighlightToCommentText = False
textHighlightColour = wdYellow
addColouredFontToCommentText = False
textColour = wdColorBlue

useCommentPane = False
paneZoom = 240

If Selection.Start = Selection.End Then
  If attachToWord = True Then
    Selection.Expand wdWord
  Else
    Selection.Expand wdSentence
  End If
End If

myStart = Selection.Start
wasEnd = Selection.End
Set rng = Selection.Range.Duplicate
rng.Start = rng.End - 1
pageNum = rng.Information(wdActiveEndAdjustedPageNumber)
lineNum = rng.Information(wdFirstCharacterLineNumber)
If Right(Selection, 1) = Chr(32) Or Right(Selection, 1) = Chr(13) Then
  Selection.MoveEnd wdCharacter, -1
  wasEnd = wasEnd - 1
End If

With ActiveWindow.View
  showCmnts = .ShowComments
  showInsDels = .ShowInsertionsAndDeletions
  showFormats = .ShowFormatChanges
  trackOnOffState = .ShowRevisionsAndComments
End With
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False

' Now create the comment
Selection.Copy
Set rng = Selection.Range.Duplicate
rng.Expand wdParagraph
Do
  rng.MoveEnd , 1
  DoEvents
Loop Until Right(rng.Text, 1) = Chr(13)
Selection.End = rng.End
Selection.Collapse wdCollapseEnd
extraBitStart = Selection.Start
If addPageNum1 = True Then preText = preText & "(p. " & _
     pageNum & ") "
If addLineNum1 = True Then preText = preText & "(line " & _
     lineNum & ") "
Selection.TypeText preText
If copySelectedText = True Then
  If useSingleQuotes = True Then
    Selection.TypeText ChrW(8216) & ChrW(8217)
  Else
    Selection.TypeText ChrW(8220) & ChrW(8221)
  End If
' Move back to between the close and open quotes
  Selection.MoveEnd , -1
' Paste in a copy of the selected text
   Selection.Paste
' Move back past the close quote
  Selection.MoveRight Count:=1
End If
If postText > "" Then
  Selection.TypeText postText
Else
  Selection.TypeText " " & ChrW(8211) & " "
End If
Selection.Start = extraBitStart
Selection.Range.Revisions.AcceptAll
Selection.Font.Name = ActiveDocument.Styles(wdStyleNormal).Font.Name
Selection.Font.Size = ActiveDocument.Styles(wdStyleNormal).Font.Size
' Either highlight it ...
If addHighlightToCommentText = True Then Selection.Range.HighlightColorIndex _
     = textHighlightColour
' And/or change the text colour to red
If addColouredFontToCommentText = True Then Selection.Font.Color = textColour
Selection.Cut
Selection.Start = myStart
Selection.End = wasEnd
Dim cmt As Comment
Set cmt = Selection.Comments.Add(Range:=Selection.Range)
Selection.Paste
ActiveDocument.TrackRevisions = myTrack
With ActiveWindow.View
  .ShowRevisionsAndComments = trackOnOffState
  .ShowComments = showCmnts
  .ShowInsertionsAndDeletions = showInsDels
  .ShowFormatChanges = showFormats
End With
If useCommentPane = False Then
  ActiveWindow.ActivePane.Close
Else
  Application.ActiveWindow.View.Zoom.Percentage = paneZoom
End If
Selection.MoveLeft , 2
cmt.Edit
End Sub