module

Option Explicit
Public p_ThisApp As clsThisApp
Sub AutoExec()
  InitiateAppClass
End Sub
Sub AutoOpen()
  InitiateAppClass
End Sub
'Call this pocedure to initialize the clase

Public Sub InitiateAppClass()
  Set p_ThisApp = Nothing
  Set p_ThisApp = New clsThisApp
lbl_Exit:
  Exit Sub
End Sub

Sub BuildControls()
Dim oPopUp As CommandBarPopup
Dim oCtr As CommandBarControl
Dim oBtn As CommandBarButton
Dim lngIndex As Long
Dim lngMarker As Long
Dim lngPosit As Long

  CustomizationContext = ThisDocument.AttachedTemplate
  'Prevent double customization
  Set oPopUp = CommandBars.FindControl(Tag:="BuiltInAC")
  If Not oPopUp Is Nothing Then GoTo lbl_Exit
  On Error GoTo lbl_Exit
  'Determine where the "Ignore All" control is located. This tells us how many suggested spellings are in the context menu.
  lngMarker = CommandBars("Spelling").Controls("&Ignore All").Index
  'Add the built-in AutoCorrect popup
  Set oPopUp = CommandBars("Spelling").Controls.Add(msoControlPopup, 30096, , CommandBars("Spelling").Controls("&Hyperlink...").Index, 1)
  With oPopUp
   .Tag = "BuiltInAC"
   .BeginGroup = True
  End With
  'I would have thought that the built-in popup would include the suggested spelling and the AutoCorrect options dialo, but it doesn't.
  'Yuck.  This means that they will have to be fudged and added\removed with each selection change :-(
  On Error GoTo Err_Posit
  lngPosit = 1
Err_Posit_Reentry:
  For lngIndex = lngPosit To lngMarker - 1
    Set oBtn = oPopUp.Controls.Add(msoControlButton, CommandBars("Spelling").Controls(lngIndex).ID)
    With oBtn
      .Caption = CommandBars("Spelling").Controls(lngIndex).Caption
      .Style = msoButtonCaption
      .Tag = .Caption
      .OnAction = "CreateAutoCorrect"
    End With
  Next lngIndex
  'Add the built-in AutoCorrect Options dialog
  Set oBtn = oPopUp.Controls.Add(msoControlButton, 793)
lbl_Exit:
  ThisDocument.Saved = True
  Set oPopUp = Nothing
  Set oBtn = Nothing
  Exit Sub
Err_Posit:
  lngPosit = lngPosit + 1
  Resume Err_Posit_Reentry
End Sub

Sub RemoveContentMenuItem()
  CustomizationContext = ThisDocument.AttachedTemplate
  CommandBars("Spelling").Reset
  ThisDocument.Saved = True
lbl_Exit:
  Exit Sub
End Sub

Sub CreateAutoCorrect(Optional strWord As String)
Dim cmdBCtl As CommandBarControl
Dim oRng As Word.Range
Dim arrChars() As String
Dim lngLen As Long, lngIndex As Long
Dim strAppend As String
  ReDim arrChars(0)
  Set cmdBCtl = Application.CommandBars.ActionControl
  Set oRng = Selection.Words(1)
  lngLen = Len(oRng)
  If lngLen <> Len(Trim(oRng)) Then
    ReDim arrChars(lngLen - Len(Trim(oRng)) - 1)
    For lngIndex = 0 To UBound(arrChars)
      arrChars(lngIndex) = Mid(oRng, Len(Trim(oRng)) + lngIndex + 1, 1)
    Next
  End If
  Application.AutoCorrect.Entries.Add Name:=Trim(oRng), Value:=cmdBCtl.Tag
  For lngIndex = 0 To UBound(arrChars)
    strAppend = strAppend & arrChars(lngIndex)
  Next lngIndex
  Selection.Words(1) = cmdBCtl.Tag & strAppend
  RemoveContentMenuItem
lbl_Exit:
  Exit Sub
End Sub