Self-Healing Ribbon Pointer (1 Viewer)

[KevinBaker]

I was replying to an old 2020 post on another forum when I found the below solution, so I wanted to make a new post with this information.

The bulk of the code below came from this old post on StackOverflow (can't post link, but search for:
"CopyMemory causes MS ACCESS crash - attempt to retrieve reference to IRibbonUI ribbon"

Below is my code. In my application, I have a single ribbon with 3 tabs (Home, cpTableView, cpPrint). Home is the default ribbon, cpTableView is used on a handful of forms that use Datasheet, and cpPrint is for Print Preview. Everything runs without any errors and for testing I put a temporary buttons on a few forms that set gRibbon = Nothing. I've done limited testing, but so far the ribbon self-heals when I set it to nothing. I plan to do more testing this week. I use Access 64bit.

Option Compare Database
Option Explicit

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)

Public gRibbonState As String, gRibbon As IRibbonUI
Dim strSQL As String, strQry As String

Public Sub onRibbonLoad(ribbon As IRibbonUI)
  Set gRibbon = ribbon
  cmSetRibbonRef gRibbon, "cpMain"
End Sub

Public Sub cmSetRibbonRef(obj As Object, ByVal RibbonName As String)
  Dim lngObj As LongPtr
 
  lngObj = ObjPtr(obj)
 
  strSQL = "UPDATE tblRibbonPtr SET Ptr = " & lngObj & " WHERE RibbonName='cpMain'"
  CurrentDb.Execute strSQL, dbFailOnError
End Sub

Public Sub cmGetRibbonRef(ByVal RibbonName As String)
  Dim obj As Object, longObj As LongPtr
 
  longObj = Nz(ELookup("Ptr", "tblRibbonPtr", "RibbonName='cpMain'"), 0)
 
  If longObj <> 0 Then
    CopyMemory obj, longObj, Len(longObj)
    Set gRibbon = obj
  End If
End Sub

Public Sub cmEnsureRibbon(ByVal RibbonName As String)
  Dim storedPtr As LongPtr
 
  If gRibbon Is Nothing Then
    AppendRibbonLog 'just for logging purposes
    cmGetRibbonRef RibbonName
  End If
 
  ' Only update the table if the stored pointer is different or missing
  If Not gRibbon Is Nothing Then
    storedPtr = Nz(ELookup("Ptr", "tblRibbonPtr", "RibbonName='" & RibbonName & "'"), 0)
    If storedPtr <> ObjPtr(gRibbon) Then
      cmSetRibbonRef gRibbon, RibbonName
    End If
  End If
End Sub

Public Sub cmSetTab(Optional newState As String = "Home")
  gRibbonState = newState
 
  cmEnsureRibbon "cpMain"
  
  If Not gRibbon Is Nothing Then
    gRibbon.Invalidate
  End If
End Sub

Public Sub GetTabVisible(control As IRibbonControl, ByRef visible)
  Select Case control.ID
    Case "Home": visible = (gRibbonState = "Home")
    Case "TableView": visible = (gRibbonState = "TableView")
    Case "Print": visible = (gRibbonState = "Print")
  End Select
End Sub

Private Sub AppendRibbonLog()
  Dim f As Integer, ts As String, ctx As String, objName As String, objType As Long, fullMsg As String
 
  On Error Resume Next
 
  ts = Format$(Now, "yyyy-mm-dd hh:nn:ss")
  objName = vbNullString
  objType = Application.CurrentObjectType        ' acForm=2, acReport=3, etc.
 
  Select Case objType
    Case acForm, acReport: objName = Application.CurrentObjectName
  End Select
 
  If objType = acForm Then
    ctx = "Form: " & objName
  ElseIf objType = acReport Then
    ctx = "Report: " & objName
  ElseIf Len(objName) > 0 Then
    ctx = "Object: " & objName
  Else
    ctx = "Object: (none)"
  End If
 
  fullMsg = ts & " - " & ctx
 
  f = FreeFile
  Open tvBEPath & "RibbonError.txt" For Append As #f
  Print #f, fullMsg
  Close #f
End Sub

Public Sub CallBackLoadImage(strImage As String, ByRef image)
  'these icons don't change, once they have been loaded
  Dim imgFolder As String

  imgFolder = "C:\ChurchPro\ImgStore\Ribbon\" & strImage

  Set image = LoadPicture(imgFolder)
End Sub

Public Function ControlEnabled(control As IRibbonControl, ByRef enabled)
  Dim frm As Form
    
  Select Case control.ID
    Case "TVFindReplace"
      On Error Resume Next
      Set frm = Screen.ActiveDatasheet
      If Err.Number <> 0 Or frm Is Nothing Then
        enabled = False
        Err.Clear
      Else
        enabled = frm.AllowEdits
      End If
    On Error GoTo 0
    Set frm = Nothing
  End Select
End Function

Public Sub RibbonAction(control As IRibbonControl)
  Dim frm As Form
 
  cmEnsureRibbon "cpMain"
..... Lots of code, removed