Locate Custom Ribbon if it Exists

[RMittelman]

As mentioned earlier in this thread, I put in code to check if the ribbon variable is Nothing, then reinstantiate it. But that never worked. Apparently, the only place you can instantiate that variable is the OnRibbonLoad event. So I just exit the database and come back, or compact/repair. Either method works. I've trained my customers do do this. Although I have put in as much error trapping as I could, there always seems to be an opportunity to encounter an untapped error. Other than this one issue, the custom ribbon has worked well for me in my applications. It is SOOOO much better than using the old switchboard method. Any other questions about implementing the ribbon, I'm happy to help.

[shcsbaker]

Thanks, I'm kinda in the same boat, I use vbWatchDog which should prevent the errors, but somewhere, somehow, the ribbon loses it's pointer. I've had my current ribbon up and running for a few years now, but would love to make it better. I've been "chanting" with Grok off and on today, it believes a self-healing Ribbon pointer is possible. I'm still in the process of updating my code, but once I'm done and have tested I'll report back my findings.

[shcsbaker]

I found some code at the below website and adapted it for use in my application (with help from chatGPT).

https://stackoverflow.com/questions/...to-iribbonui-r

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 only 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

[pbaldy]

Post 33 was moderated, I'm posting to trigger email notifications.