Sub CommentAdder()
' Paul Beverley - Version 23.08.22
' Adds a comment off a menu

useCommentPane = False
paneZoom = 240

addItalic = True
addbold = True

' myDefaultSelect = "sentence"
myDefaultSelect = "word"

' useDoubleQuotes = False
useDoubleQuotes = True

addJustPageNum = False
addPageAndLineNum = False

maxLen = 100

cm = "Start\"
cm = cm & ",Dummy\"
cm = cm & "a '[]' is something I’ve /got/ and */you’d/* like, 'yes'?\"
cm = cm & "l '[]' is not in the references list.\"
cm = cm & "L AU: '[]' is not in the references list. (But '[]|', is.)\"
cm = cm & "c '[]' - Not cited in the text.\"
cm = cm & "h '[]' - Have I caught the *intended* meaning? /Well?!/\"
cm = cm & "r '[]' - Will the /readers/ know what this means? If so, fine.\"
cm = cm & "R AU: '[]' - Will readers know what '|' refers to? If so, that's fine.\"
cm = cm & "s '[]' - Sorry, but I can't work out the intended meaning here. Is it something like '[]|'?\"

maxLenPrompt = 100


If Selection.Start = Selection.End Then
  If InStr(myDefaultSelect, "nten") > 0 Then
    Selection.Expand wdSentence
  Else
    Selection.Expand wdWord
  End If
End If
Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
  Selection.MoveEnd , -1
  DoEvents
Loop
pageNum = Selection.Information(wdActiveEndAdjustedPageNumber)
lineNum = Selection.Information(wdFirstCharacterLineNumber)

cm = Replace(cm, " - ", " " & ChrW(8211) & " ")
If useDoubleQuotes = True Then
  cm = Replace(cm, " '", " " & ChrW(8220))
  cm = Replace(cm, ",'", "," & ChrW(8220))
  cm = Replace(cm, "' ", ChrW(8221) & " ")
  cm = Replace(cm, "'", ChrW(8221))
  cm = Replace(cm, ChrW(8221) & "r", ChrW(8217) & "r")
  cm = Replace(cm, ChrW(8221) & "m", ChrW(8217) & "m")
  cm = Replace(cm, ChrW(8221) & "t", ChrW(8217) & "t")
  cm = Replace(cm, ChrW(8221) & "s", ChrW(8217) & "s")
Else
  cm = Replace(cm, " '", " " & ChrW(8216))
  cm = Replace(cm, ",'", "," & ChrW(8216))
  cm = Replace(cm, "'", ChrW(8217))
End If
cmt = Split(cm, "\")
indx = ""
ns = UBound(cmt) - 1
For i = 1 To ns
  If InStr(cmt(i), "Dummy") = 0 Then
    indx = indx & Left(cmt(i), 1)
    myBit = cmt(i)
    If Len(myBit) > maxLenPrompt Then
      myBit = Left(myBit, maxLenPrompt)
      Do
        myBit = Left(myBit, Len(myBit) - 1)
      Loop Until Right(myBit, 1) = " "
      myBit = myBit & ChrW(8230)
    End If
    myPrompt = myPrompt & myBit & vbCr
    cmt(i) = Mid(cmt(i), 3)
    DoEvents
  Else
    indx = indx & "_"
  End If
Next i
indx = indx

myPrompt = Replace(myPrompt, "[]", "") _
     & vbCr & "Comment?"
myPrompt = Replace(myPrompt, "/", "")
myPrompt = Replace(myPrompt, "*", "")

Do
  myCode = InputBox(myPrompt, "CommentAdder")
  n = InStr(indx, myCode)
  If n = 0 Then Beep
Loop Until n > 0
If myCode = "" Then Exit Sub

If Selection.Start = Selection.End Then Selection.MoveEnd , 1
Selection.Copy
Application.ScreenUpdating = False
On Error GoTo ReportIt

Set myComment = Selection.Comments.Add(Range:=Selection.Range)
myComment.Edit
myFontSize = myComment.Range.Font.Size

myStart = Selection.Start
myPLtext = ""
If addPageAndLineNum = True Then
  myPLtext = "(p. " & pageNum & ", line " & lineNum & ") "
Else
  If addJustPageNum = True Then myPLtext = myPLtext & "(p. " & _
     pageNum & ") "
End If
Debug.Print myPLtext
Selection.TypeText Text:=cmt(n)
txtPos = InStr(cmt(n), "[]")
txtPos2 = 0
If txtPos > 0 Then txtPos2 = InStr(Mid(cmt(n), txtPos + 2), "[]")
If txtPos2 > 0 Then
  txtPos2 = txtPos2 + txtPos + 1
  Selection.Start = myStart + txtPos2 - 1
  Selection.End = myStart + txtPos2 + 1
  Selection.Paste
End If
If txtPos > 0 Then
  Selection.Start = myStart + txtPos - 1
  Selection.End = myStart + txtPos + 1
  Selection.Paste
End If
Application.ScreenUpdating = True

Set rng = Selection.Range.Duplicate
If highlightColour > 0 Or fontColour > 0 Or isUL Then
  Selection.Collapse wdCollapseStart
  Selection.MoveEnd , 1
End If

Selection.Expand wdParagraph
If Asc(Selection) = 5 Then
  Selection.MoveStart , 1
End If
Selection.Collapse wdCollapseStart
Selection.TypeText Text:=myPLtext
Selection.Expand wdParagraph
Selection.Range.Font.Size = myFontSize

Set rng = Selection.Range.Duplicate

' Add italic
If addItalic = True Then
  italicPos = InStr(Selection, "/")
  Do While italicPos > 0
    If italicPos > 0 Then
      Selection.MoveStart , italicPos - 1
      Selection.End = Selection.Start + 1
      Selection.Delete
      rng.Select
      Selection.MoveStart , italicPos - 1
      italicEndPos = InStr(Selection, "/")
      If italicPos > 0 Then
        Selection.End = Selection.Start + italicEndPos
        Selection.Font.Italic = True
        Selection.Collapse wdCollapseEnd
        Selection.MoveStart , -1
        Selection.Delete
      End If
    End If
    rng.Select
    italicPos = InStr(Selection, "/")
  Loop
End If

' Add bold
If addbold = True Then
  rng.Select
  boldPos = InStr(Selection, "*")
  Do While boldPos > 0
    If boldPos > 0 Then
      Selection.MoveStart , boldPos - 1
      Selection.End = Selection.Start + 1
      Selection.Delete
      rng.Select
      Selection.MoveStart , boldPos - 1
      boldEndPos = InStr(Selection, "*")
      If boldPos > 0 Then
        Selection.End = Selection.Start + boldEndPos
        Selection.Font.Bold = True
        Selection.Collapse wdCollapseEnd
        Selection.MoveStart , -1
        Selection.Delete
      End If
    End If
    rng.Select
    boldPos = InStr(Selection, "*")
  Loop
End If

' Now position the cursor
rng.Select
cursorPos = InStr(Selection, "|")
If cursorPos > 0 Then
  Selection.Collapse wdCollapseEnd
  i = 0
  Do
    Selection.MoveLeft , 1
    i = i + 1
    DoEvents
  Loop Until Selection = "|" Or i > maxLen
  If i > maxLen Then
    MsgBox ("You might need to increase the value of ""maxLen"" in the macro.")
    Exit Sub
  End If
  Selection.MoveEnd , 1
  Selection.Delete
Else
  Selection.MoveEnd , -1
  Selection.Collapse wdCollapseEnd
End If

If useCommentPane = False Then
  ActiveWindow.ActivePane.Close
Else
  Application.ActiveWindow.View.Zoom.Percentage = paneZoom
End If
Exit Sub

ReportIt:
Application.ScreenUpdating = True
On Error GoTo 0
Resume
End Sub