Sub CommentAddMenu()
' Paul Beverley - Version 26.02.24
' Adds a comment off a menu

useCommentPane = False
paneZoom = 240

myPrefix = "PB: "
myPrefix = ""

addPageNum = False
addLineNum = False

listName = "zzSwitchList"

' On Windows, it will need to be something like:
myFolder = "C:\Documents and Settings\Paul\My Documents\Macro stuff\"

' On a Mac, it will need to be something like:
myFolder = "/Users/Paul/My Documents/Macro stuff/"


defaultList = myFolder & listName
Set textDoc = ActiveDocument
If Selection.Start = Selection.End Then
  Selection.Expand wdSentence
  If Right(Selection, 4) = "al. " Or Right(Selection, 5) = "al., " Then
    Selection.MoveRight Unit:=wdSentence, Count:=1, Extend:=wdExtend
  End If
  Do While InStr(" " & vbCr, Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
End If

On Error Resume Next
Set thisDoc = ActiveDocument.ActiveWindow
dirName = ActiveDocument.Path
' Go and look for the list file
gottaList = False
For i = 1 To Application.Windows.Count
  If InStr(Application.Windows(i).Document.Name, _
       listName) > 0 Then
    Set listDoc = Application.Windows(i).Document
    gottaList = True
  End If
Next i
If gottaList = False Then
  Documents.Open dirName & "\" & listName
  If Err.Number = 5174 Then
    Err.Clear
    Documents.Open defaultList
    If Err.Number = 5174 Then
      Err.Clear
      Documents.Open defaultList & ".docx"
    End If
    If Err.Number > 0 And Err.Number <> 438 Then GoTo ReportIt
  End If
End If
On Error GoTo 0
Set rng = listDoc.Content

rngEnd = rng.End
' Find first comment line
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[[My comments]]"
  .Wrap = wdFindContinue
  .Forward = True
  .MatchWildcards = False
  .MatchCase = False
  .MatchWholeWord = False
  .MatchSoundsLike = False
  .Execute
End With
If rng.Find.Found = 0 Then
myPrompt = "Your comments text must start with: ""[[My comments]]"""
  Beep
  myResponse = MsgBox(myPrompt, _
       vbQuestion + vbOKCancel, "CommentAddMenu")
  If myResponse <> vbYes Then Exit Sub
End If

' Find first item in list of comments
rng.Collapse wdCollapseEnd
rng.Expand wdParagraph
rng.Collapse wdCollapseEnd
listStart = rng.Start
rng.End = rngEnd

' Construct myFullPrompt
myFullPrompt = ""
allCodes = ""
myLine = rng.Paragraphs(1)
textLeft = rng.Text
Do
  sqPos = InStr(myLine, "] ")
  If sqPos = 0 And LCase(textLeft) <> UCase(textLeft) Then
    rng.Paragraphs(1).Select
    MsgBox "Please check the formatting of this line."
    Beep
    Exit Sub
  End If
  curlyPos1 = InStr(myLine, "{")
  curlyPos2 = InStr(myLine, "}")
  If curlyPos1 * curlyPos2 = 0 Then
    rng.Paragraphs(1).Select
    MsgBox "This line needs a prompt text inside {} brackets."
    Beep
    Exit Sub
  End If
  myCode = Mid(myLine, 2, sqPos - 2)
  myPrompt = Mid(myLine, curlyPos1 + 1, curlyPos2 - curlyPos1 - 1)
  If InStr(allCodes, "[" & myCode & "]") = 0 Then
    myFullPrompt = myFullPrompt & myCode & " = " & myPrompt & vbCr
  End If
  allCodes = allCodes & Left(myLine, sqPos)
  rng.Start = rng.Paragraphs(1).Range.End
  myLine = rng.Text
  DoEvents
  textLeft = rng.Text
Loop Until LCase(textLeft) = UCase(textLeft)
myFullPrompt = Left(myFullPrompt, Len(myFullPrompt) - 1)
myResponse = InputBox(myFullPrompt, "Comment Add Menu")
If myResponse = "" Then
  Beep
  Exit Sub
End If
rng.Start = listStart

'Now pick up the chosen comment
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[" & myResponse & "]"
  .Wrap = wdFindContinue
  .Forward = True
  .MatchWildcards = False
  .MatchWholeWord = False
  .MatchSoundsLike = False
  .Execute
End With

If rng.Find.Found = False Then
  Beep
  Exit Sub
End If

' Select required comment
rng.Expand wdParagraph
myLine = rng.Text
sqPos = InStr(myLine, "] ")
rng.MoveStart , sqPos + 1
myLine = rng.Text
curlyPos1 = InStr(myLine, "{")
rng.End = rng.Start + curlyPos1 - 2
cursorPos = InStr(rng, "][")
lenCopy = Len(rng)
If lenCopy > 1 Then rng.Copy

' Find page and line number within text
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
myStart = Selection.Start
wasEnd = Selection.End
Set rng = Selection.Range.Duplicate
rng.End = myStart + 1
pageNum = rng.Information(wdActiveEndAdjustedPageNumber)
lineNum = rng.Information(wdFirstCharacterLineNumber)


' Now create the comment
Dim cmt As Comment
Set rngText = Selection.Range.Duplicate
Set cmt = Selection.Comments.Add(Range:=Selection.Range)
If useCommentPane = False Then
  ActiveWindow.ActivePane.Close
  cmt.Edit
Else
  Application.ActiveWindow.View.Zoom.Percentage = paneZoom
End If

myPLtext = ""
If addPageNum = True Then myPLtext = myPLtext & "(p. " & _
     pageNum
If addLineNum = True Then
  myPLtext = myPLtext & ", line " & lineNum & ") "
Else
  myPLtext = myPLtext & ") "
End If
If Len(myPLtext) > 4 Then myPrefix = myPrefix & myPLtext
If Len(myPrefix) > 0 Then Selection.TypeText myPrefix
For i = 1 To 200
  DoEvents
Next
If lenCopy > 1 Then Selection.Paste
For i = 1 To 200
  DoEvents
Next

' Replace the <> with the quote
cmt.Range.Select
rngText.Copy
quotePos = InStr(Selection, "<>")
Do While quotePos > 0
  Selection.Start = Selection.Start + quotePos - 1
  Selection.End = Selection.Start + 2
  Selection.Delete
  Selection.Paste
  cmt.Range.Select
  quotePos = InStr(Selection, "<>")
Loop
Application.ScreenUpdating = True

ActiveDocument.TrackRevisions = myTrack
cmt.Range.Select
cursorPos = InStr(Selection, "][")
If cursorPos > 0 Then
  myLen = cmt.Range.Characters.Count
  Selection.MoveStart , cursorPos - 1
  Selection.End = Selection.Start + 2
  Selection.Delete
End If
If cursorPos > 0 Then
  cmt.Edit
  Selection.MoveLeft , (myLen - cursorPos - 1)
Else
  If lenCopy > 0 Then cmt.Edit
  Selection.TypeText " "
End If
Exit Sub

ReportIt:
If Err.Number = 5174 Then
  MsgBox ("Couldn't find file: " & listName)
Else
  On Error GoTo 0
End If
End Sub