lynnnow
08-18-2024, 11:43 PM
I upgraded to a new machine and my Excel custom ribbon fails to load sometimes. My previous PC had Win 10 with Office 365 and am using the same OS and Office on the new machine, however, the ribbon doesn't load sometimes and I cannot understand why. It used to successfully load previously, there have been no code updates between the old and new PC. This is a distributed workbook that works successfully on the rest of the team's PCs.
This part of the ribbon tells me if has been loaded or not
http://www.vbaexpress.com/forum/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAARYAAABoCAYAAAA0Et9KAAAAAXNSR0IArs4c6QAA AARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAABB0SURBVHhe7Z1rjBbVGcefXbq 7gu0ucllxhUVMuex2lUWKK4tA0VohJLSmxlTBpDHhg5cvRiVG/dAPagxqNLHGDzamibeGYGybEKAUKSoXFQu0BBRKBZabsCzseuGy3d2 /9k5L8fXmXfnnTkz7ztn/79ksjNnZp4zz8y8/3nOmTnPlg0bNqxPCCHEIOXuX0IIMQaFhRBinGxTqK PLSJCiBnK6urq oYOHSoVFRVSVlbmFhNCSHjKa2pqpLKykqJCCDEG 1gIIcahsBBCjFPW0NDAXltCEgJ9mZMnT5YFCxYIuiFKlc7OTtm2bZts3LhRent73dLgUFgISYjy 8nJ54IEHZNeuXc50/vx5d03pUVVVJU1NTTJ9 nR58cUXpbu7210TjCGjR4/ nTtPCImRGTNmyLlz5 Sjjz6Snp4et7Q0wfEdO3bMEb/a2lo5cuSIuyYY7GMhJCGam5udSCVN7Nu3T bOnesuBYfCQkhC1NfXO30XaQIRS5i oET6WDpHXyddIxrl/LAx0j10lFvaT8XZdqn69rhUd yWmpP/dEvTga1WGbv0n78 STT8qzzz7rLoXnmlunyeWTr5Af1Q2XMePGuKX9HG87Ll8dPSNffn5M/r12u1sajUceeUSeeOIJdykYsQpL 9h5cqpujvT19khf13GRb9oz08mMDH7Tv0HVpSKXjs5Mo6SseoyUlQ RkUffl1GHN/SvL1Fs9csP2/wtlj9RheWnt90gU35xrVzovSBHu07KkVNfyqH2o/LNuW d9ZdeMkzqR9XJlSMvl7rq0VJZXimf/e1fsu3drc76sJSMsHw9okGOXX2b0wHUd JzkY4D7poBGHGVlNVOliFDhsgV/31Xftixx11RGtjqlx 2 Vtsf8IKS/3UCTLzt3PkQnmP7Gj7TPYc/o 7Jj8NY38szeOmSGXvENnyx/fl0M4v3DWFkU9YZs eLR988IG7dBHjb4U6xrTKsQmLpLejTeSLTSJnz7hrAoBt2/dLb8Uw WrsLCnv6ZahX2fslAC2 uWHbf6Wgj833XSTbN682V0KBpo9LUtmy/7TbbJq z kvavDXTMw2HbX4b1SU1Mt182dLn3/65UT zMRWoHMmjVL3nvvPXfpu4wfP14OHTrkLl3EaOctLt6X4xdI36FPRI7udEtDkNkXNmALNouNrX75 YZu/afUHonL9b2bJ3/dslvd3Z449JNgXNmALNpPAmLAgzDxRf4vIwS0inUfd0gjARsYWbMJ2sbDVLz9s8zet/qD5M/VXM5wo5cCJw25peGADtmATtuPGmLCg7dp3KtNmNXHxFBlbsAnbxcJWv/ywzd 0 oM lb0nvzAiKujUbZ7Q6NiCTdiOGyPCgl52dIhFCjP9yNiEbdSRNLb65Ydt/qbVH7z9QUdtlOaPAqLy6 tvlXlNN0jLxGbHJmyjjjgxIizOqzv0sscEbKOOpLHVLz9s8zet/uCVMt7 REWJSteBDlm1/F1pnXKdE7nANuqIk8jCgo M8D1A4Fd3YcjYRh2oKyls9csP2/xNqz/oXMV3KkFfKfuhi8qa5X RxluvlVOdp2XfsQOObdQRZ0duZGHBl4vOR0YxgzpQV1LY6pcftvmbVn/wRS0 fotCrqjMX/ZLqb5qhLzz8drsx3SoA3XFRWRhwefQzpeLcZOpw6krIWz1yw/b/E2rP/hMH1/UhiWIqADUgbriIrKwOGMs8Dl03GTqyB3PESe2 uWHbf6m1R M/cFn mEIKioAdeSOMzKJkc7b7BiLOEmijlxs9csP2/xNqT 5IoAOV4hGPgoRFeBVZhIzwkIIiQW8IsarYoiGn7gUKipJYEZYMBo0bpKoIxdb/fLDNn9T6o8SEEQqeEWMV8UQDS9xCSsqfiJlisjCgrwVzhDzuMnU4dSVELb65Ydt/qbVH RTQeoDgFfDeEWMV8UQjVxxCSsqAHWgrriILCxIhoO8FbGTqcOpKyFs9csP2/xNqz9I0oR8KgDiAJGAWEA0dHGprRkVWlQA6kBdcRFZWJBhC8lw4gZ1oK6ksNUvP2zzN63 IPMbkjQp/MRl8ZxFoUUFoA7UFReRhQVp 5BhC8lwYgOJdjJ1JJny0Fa//LDN37T6g3SSyPyGJE0KL3H5ZOXm0KIC26jDVOpKL4x03iJtHzJsxQVso46ksdUvP2zzN63 IJ0kMr/p5IoL0k2GERUA26gjTowIC3KBIm2f1E11SwySsQnbxcifaqtfftjmb1r9gWggneScxhluST 6uCz5/dJQogKbsB01D 5AGBEWgFygZSMzYWdNf4 2ETK2YBO2i4Wtfvlhm79p9Qc5aieNniBX1Y51S/pR4nLiQkfBogJbsAnbcWNMWJBguPbQOpHxM81cRNjI2ILNYiZjttUvP2zzN63 IPH1zj9/Igun/cxTXP768fqCRQW2YDNsUu1CMCYsYMTxzXL5wdVSVp8J4aKEn5l9YQO2YLPY2OqXH7b5m1Z/0Ln68Z82yc8bWr/XLCoE7AsbsBVnh62O8Sz9yF5 ydkT8m3d9dI38moR5MQ4G/B9OXrZx7fID4bVyJX735Gak8mchCDY6pcftvlbCv6EydKPrPpnDnfINS1N0lg/UXqkN3Cmfrz9ueUnrTKqskY2/WGD7NsULsIKk6Wf/7AsBLb65Ydt/hbLHxv/YZnf/xXiv1iNgK1WGbv0n7Y O/WC2qsBBCzAlL0oQRFqOdt4QQAigshBDjUFgIIcahsBBCjENhIYQYh8JCCDEOhYUQYpyChGX37t3 y9ttvu0sXQfn06dPdpWSJq 7Vq1c7tnOnl19 2d0ifeT6Esd5e/zxxx3bhX66bopcH3E8hYBzgv2KdT vWbNGtmzZ4kyYDwq2b25udpf8Wb58eda Pr366qvuFmYoOGKZOnWqLFmyxF2ylwULFkhjY6MzgbvvvtuZv//53ltKL8ePPNN Wll15yS82xcOFCefrpp6W1tdUtSR7lI45j8eLFbqk/upB8 umnzr74myQQBfzA161bJzNnznSmRx99VB566CFnPdYFEY6BWLZsWdY phdeeMEpX7p0qfPXFAULC27I67z10iaeWpp56S4cOHG38yw aePaWRDuKNN95w/hYr iiExx57TFauXCnPP/ 8WyKyY8eO7yzHwT333OPUa5qChQXh2cGDB8WvSaBCSa9QFMtoSuGvWkb0o2 rQmlMeh1608SrOZYUqn78BX7HheUgvhQaqscFjkX3K9919FuHefD6669nz4W rd48wrLfeTR1TmDnzJkz2ejD61qp vVjRpkSI3U8aj/9Our3LsrxV 1XCIhExo0b5ysiiFbAK6 8km2yqOaLWufFQE0pNIu6urpiEa9Qnbd33nmnzJs3z/MkIrxGVINwEiEpQlF9u46ODmedAuv1sLWpqSm7jDoUetMEzbEwF9AUug/5juvGG290ynVf1M2u9kHkUAzwQ8ADQg/5db/yXUe/dWpflOEeAdhWNU1WrVqV/fECVZ/pcwKRwI8c519vknldK8wD/Zhz8bqOAJG7Og9RmDRpknR2drpL3wdNFnDvvfd p8ly vTp7LpCgZhhnA98ioNQwgJwQjGoSgcKjlBY3Ri4aXHzzp8/31kGr732mjvXD wAFbY 99xzzt/cMFZ/aoCGhgbnbzHQfch3XGrglu4LniK4qfUnX5KoH920adOcH5qO8ivfdQxyjRVqW1UnBAjLClWf6XM CkcCEXCE6Ye8hr sI34A6D1H63vbu3Ss1NTXuUnDeeustd 4id9xxhxPFYIJNNa/6ahRoemHwIJpbcRBaWNQJxcWKQpD2OC6kimww4elWCoQ5LvwQ1RMON7i6QZNCRQ/6kzxO9EgEU66YgTjOCWxu2LAhK1aleg8B/LgRseTMOwYsWKbMcsbKp5vbmDJlB1dbXTkRsXoYUFQMlxsRRK0ZXY4GLiqVHIazMv8GTBUxGop2 ApEOW48ITDjR82lI2TfNexkGuMbXFOgj58TJ8T2FNN9oGuVdDoRaF8UyIY9QGLt0G33367E3EoM K LDZpMUVFNoNyWg2kiCYt6KujgiQixwZMHITDacNguCriICOtgE7ZL5WkT5rhwA2J7TLjpS/X1db7rWMg1xjq1LSa9j0UR5znB/Yl nnzXaufOnU7TwOvY8oFmPPaDTfQNRgERBfpQHnzwwWzzBUKjIo1du3Y56wr53sSreYrjBXo9mEx/x8JET4QYAFERRFY16bxgoidCSEE8/PDD2aYWobAQEhp8l6OacHir5dUxPVihsBASErxZU2 Z8jWBBiMUFkKIcSgshBDjUFgIIcYxJizowPL7DkAfoIVJzRcDDETDlIt TMU8PtMMNn/Tgv4NCaYoX91if7 UCvnW RFmn1yMRiy5g/AUGJeiwIdU6OiK tFcGHBs EgKk4kfUtI/yELrG2z pg18EOf1yb0NGBUWfMGI/A46 KqyVN7v49i2b9/uTLnHaSODzV9SOhgVFgyL14eVAww5R7mO/iTCvP5Jtz7CVc fEXUsBkDkhDESCPX0KCofOE51DPpxYB7ga0s9jwfGjujb vmm283NU K1D aBXt9ADDZ/bQDXCs0i/MWEAYMKDDBU5bmf4N98882eigeaO20cd26eVxaKUWHBSGVELepmVAO0ME4jH0nkLVHHgiaYOh5V lo9Cco8ArFe YN4vv0y PCVe58OvPj8Gm79pBImb1A9a79NoaWlxmkdIG4lP5hUYlKiaTjjPXvugeYV9vPpInnnmmWzzC4M elTihHFnkUG4Ko8ICcNPgRgHIf/rhhx868/lIIm8JjgVNAgXmUZYP/BAxgjVI7hFFkPwyyi6exngy4wepj7b1Oh FMtj8TSN6H4ueFwUCCxChACUSeiQD9NHOah/YaWtrcyIYHYgS tqUmGGAI5bVaGrVx2MqlYJxYVE3ByIODKcPG2ngplZPLdyMQZ62 YBI4WkIW5gwjzLTBM33qkdjmEx/Dj7Y/LUdiAvEQAlRvoxzfuj5WTDpKRpMY1xYAKIUPJX0J2ZYTOTogMjhyavf2JhQppptXugiCfAkzc09 UmgeDwC7eGLnq9uPIPUNNn8HA4hOEIkAFX3o3HXXXc5frEP 3PXr1zvLCkQ/2Cf3tbYqVyIT5bW3TizCgigFT6goeTVwE pP2yi20DTzapKhTDXb/FD9DDgOhPIIORFNgbB5PADsKLuYgtgIWt9g8zet6H0sA3WaQgCQ9U01Y3Ijlssuu8xZhzwr6C/xSjmJPhvsq pUfSzYXuVnmTJlilMWFeZjISQhmI FEEIiQGEhhBiHwkIICY1XMwhQWAghxqGwEEKMQ2EhJCHwiriqqspdSgdhj5fCQkhCbNy4USZOnO gupQOMScr92C4IFBZCEmLbtm3OUIao/9wsCRCp4Dgxbd261S0NDj QIyRBKioqnBQWixYtcktKEzTbMA5s7dq10t3d7ZYGh8JCCDEOm0KEEONQWAghxqGwEEKMQ2EhhB iHwkIIMQ6FhRBiHAoLIcQ4FBZCiHEoLIQQ41BYCCHGobAQQoxDYSGEGIfCQggxDoWFEGIcCgshx DgUFkKIcSgshBDjUFgIIcYpb29vl56eHneREEKiIvJ/0ds5zMKKhhIAAAAASUVORK5CYII=
31756
These are toggle buttons that are updated on demand and if the ribbon is not loaded (or loaded correctly), clicking either of these buttons crashes Excel. There are other buttons as well on the same ribbon that work without issue when clicked, it's just these buttons that cause it to crash.
I always insert the URL in my projects for where I get my code help from, unfortunately the link I copied for these bits of code was terribly wrong (which I learned about today, after all these years)
Sub RibbonOnLoad(ribbon As IRibbonUI)
Public myRibbon As IRibbonUI
Public MyTag As String
Public PressedState As Boolean
Public blnCtrlZ As Boolean
'Callback for customUI.onLoad
Sub RibbonOnLoad(ribbon As IRibbonUI)
Set myRibbon = ribbon
If Not StoreObjRef(myRibbon) Then Beep: Stop
If ThisWorkbook.Sheets("Sheet1").ProtectContents = False Then
Sheets("HD").Range("E1").Value = True
blnCtrlZ = True
End If
End Sub
Sub GetPressed(control As IRibbonControl, ByRef returnedVal)
returnedVal = blnCtrlZ
End Sub
Sub GetVisible(control As IRibbonControl, ByRef visible)
'Stop
Dim rngProofer As Range, rngTranscriber As Range
'-x--- ver 3.5.3 - Jul 3, 2020
If CreateObject("WScript.Network").userdomain = "DomainName" Then
Set rngProofer = ThisWorkbook.Sheets("HD").Range("ProofName").Find(LCase(Environ("Username")))
Set rngTranscriber = ThisWorkbook.Sheets("HD").Range("TransName").Find(LCase(Environ("Username")))
Else
If strEnvironUsername <> vbNullString Then
Set rngProofer = ThisWorkbook.Sheets("HD").Range("ProofName").Find(LCase(strEnvironUsername))
Else
Set rngTranscriber = ThisWorkbook.Sheets("HD").Range("TransName").Offset(0, 1).Find(LCase(TransCr))
End If
End If
'-x--- ver 3.5.3 - Jul 3, 2020
If LCase(Environ("Username")) = "abc" Or _
ElseIf Not rngProofer Is Nothing Then
MyTag = "Proofers"
ElseIf Not rngTranscriber Is Nothing Then 'ver 3.2.4 - 2/24/2017
MyTag = "Transcribers"
End If
If control.Tag Like MyTag Then
visible = True
Else
visible = False
End If
End Sub
Sub RefreshRibbon(Tag As String)
MyTag = Tag
If myRibbon Is Nothing Then
MsgBox "Error, restart your workbook"
Else
myRibbon.Invalidate
End If
End Sub
Sub GetLabel(control As IRibbonControl, ByRef label)
Select Case control.id
Case "A01"
Select Case PressedState
Case True: label = "Converted Mins": Sheets("HD").Range("D1").Value = True
Case False: label = "Normal Mins": Sheets("HD").Range("D1").Value = False
End Select
Case "A02"
Select Case PressedState
Case True: label = "Delete Allotment Pane"
Case False: label = "Trans Allotment": Sheets("HD").Range("B1").Value = 1
End Select
Case "A03"
Select Case PressedState
Case True: label = "Delete Allotment Pane"
Case False: label = "Proofers Allotment": Sheets("HD").Range("B1").Value = 2
End Select
Case "A04"
Select Case PressedState
Case True: label = "Rating"
Case False: label = "Rating"
End Select
Case "A05"
' If Sheets("HD").Range("F1").Value = 0 Then
' PressedState = True
' End If
Select Case blnCtrlZ 'Sheets("HD").Range("E1").Value
Case True: label = "Ctrl+Z Enabled"
Case False: label = "Ctrl+Z Disabled"
End Select
End Select
End Sub
'Note: I use two of the 1871 Built-in buttons in this example
Sub GetImage(control As IRibbonControl, ByRef image)
Select Case control.id
Case "A01"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A02"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A03"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A04"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A05"
Select Case blnCtrlZ
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
End Select
End Sub
The ObjStore is run in a separate module as such:
Option Explicit
Public Const C_OBJ_STORAGENAME As String = "thisWorkbook_IRibbonUI_Ptr"
'Added PtrSafe - 12th July 2020 reverted on Jul 24
Declare PtrSafe Function CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal length As Long)
Public Function StoreObjRef(obj As Object) As Boolean
' Serialize and savely store an object reference
StoreObjRef = False
' Serialize
'Changed to LngPtr 12th July 2020
Dim longObj As Double 'LongPtr
longObj = ObjPtr(obj)
' Store into a defined name
If IsNumeric(Range(C_OBJ_STORAGENAME)) Then
Range(C_OBJ_STORAGENAME) = longObj
'Debug.Print "Save storage """; C_OBJ_STORAGENAME; """ stored the object reference"; longObj
End If
' Return
StoreObjRef = True
End Function
Public Function RetrieveObjRef() As Object
' Retrieve from save storage, deserialize and return the object reference
' stored with StoreObjRef
Set RetrieveObjRef = Nothing
' Retrieve from a defined name
Dim longObj As Double
If IsNumeric(Range(C_OBJ_STORAGENAME)) Then
longObj = Range(C_OBJ_STORAGENAME)
'Debug.Print "Object reference"; longObj; "retrieved from save storage """; C_OBJ_STORAGENAME; """"
' Deserialize
Dim obj As Object
CopyMemory obj, longObj, 4
' Return
Set RetrieveObjRef = obj
Set obj = Nothing
End If
End Function
Private Sub use_NameWithoutRef()
' Just demonstrate how a name with no reference would be used
Const C_OBJ_STORAGENAME_NOREF As String = "foo"
Dim aName As Name, longObj As Double
' On each access check if the name exists.
' If not, create it with no reference to a cell and value 0
With ThisWorkbook
On Error Resume Next
Set aName = .Names(C_OBJ_STORAGENAME_NOREF)
On Error GoTo 0
If aName Is Nothing Then
Set aName = .Names.Add(Name:=C_OBJ_STORAGENAME_NOREF, RefersTo:=0)
End If
End With
' store some Long under that Name
longObj = Timer
aName.Value = longObj ' Value is "=4711"
'Debug.Print "Save storage """; C_OBJ_STORAGENAME_NOREF; """ stored the object reference"; longObj
' retrieve some Long from that Name
longObj = Mid(aName.Value, 2)
'Debug.Print "Object reference"; longObj; "retrieved from save storage """; C_OBJ_STORAGENAME_NOREF; """"
End Sub
Public Function ReloadRibbon(Optional id As String = "") As Boolean
' Force the ribbon UI to reload so that states are refreshed.
' This is done by an Invalidate or InvalidateControl(id)
' Returns True if successful
ReloadRibbon = False
' Invalidate the ribbon UI so that everything gets reloaded
If Not (myRibbon Is Nothing) Then
' Invalidate will force the UI to reload and thereby ask for current states
If Len(id) > 0 Then
myRibbon.InvalidateControl id ' Note: This does not work reliably
Else
myRibbon.Invalidate
End If
ReloadRibbon = True
Exit Function
Else
' The static guiRibbon-variable was meanwhile lost.
' We try to retrieve it from save storage and retry Invalidate.
On Error GoTo GiveUp
Set myRibbon = RetrieveObjRef()
If Len(id) > 0 Then
myRibbon.InvalidateControl id ' Note: This does not work reliably
Else
myRibbon.Invalidate
End If
On Error GoTo 0
ReloadRibbon = True
Exit Function
GiveUp:
MsgBox "Due to a design flaw in the architecture of the MS ribbon UI you have to close " & _
"and reopen this workbook """ & ThisWorkbook.Name & """." & vbNewLine & vbNewLine & _
"Very sorry about that." & vbNewLine & vbNewLine & _
"You will then have no problems anymore." _
, vbExclamation + vbOKOnly, ThisWorkbook.Name & ".ReloadRibbon"
' Note: In the help we can find
' guiRibbon.Refresh
' but unfortunatly this is not implemented.
' It is exactly what we should have instead of that brute force reload mechanism.
End If
End Function
So all this code has been working perfectly and without issue from nearly 2017, but it fails on my new PC, and I'm at my wit's end to try to understand why and where it is failing. The code runs successfully every time even on Win 7 + Office 2010 (32 bit). Hoping someone can give me a nudge in the right direction to get this issue sorted.
I have even tried repairing my Office installation, uninstalled and reinstalled Office, but it still fails to load sometimes. Any help is appreciated
Regards,
Lincoln
This part of the ribbon tells me if has been loaded or not
http://www.vbaexpress.com/forum/image/png;base64,iVBORw0KGgoAAAANSUhEUgAAARYAAABoCAYAAAA0Et9KAAAAAXNSR0IArs4c6QAA AARnQU1BAACxjwv8YQUAAAAJcEhZcwAADsMAAA7DAcdvqGQAABB0SURBVHhe7Z1rjBbVGcefXbq 7gu0ucllxhUVMuex2lUWKK4tA0VohJLSmxlTBpDHhg5cvRiVG/dAPagxqNLHGDzamibeGYGybEKAUKSoXFQu0BBRKBZabsCzseuGy3d2 /9k5L8fXmXfnnTkz7ztn/79ksjNnZp4zz8y8/3nOmTnPlg0bNqxPCCHEIOXuX0IIMQaFhRBinGxTqK PLSJCiBnK6urq oYOHSoVFRVSVlbmFhNCSHjKa2pqpLKykqJCCDEG 1gIIcahsBBCjFPW0NDAXltCEgJ9mZMnT5YFCxYIuiFKlc7OTtm2bZts3LhRent73dLgUFgISYjy 8nJ54IEHZNeuXc50/vx5d03pUVVVJU1NTTJ9 nR58cUXpbu7210TjCGjR4/ nTtPCImRGTNmyLlz5 Sjjz6Snp4et7Q0wfEdO3bMEb/a2lo5cuSIuyYY7GMhJCGam5udSCVN7Nu3T bOnesuBYfCQkhC1NfXO30XaQIRS5i oET6WDpHXyddIxrl/LAx0j10lFvaT8XZdqn69rhUd yWmpP/dEvTga1WGbv0n78 STT8qzzz7rLoXnmlunyeWTr5Af1Q2XMePGuKX9HG87Ll8dPSNffn5M/r12u1sajUceeUSeeOIJdykYsQpL 9h5cqpujvT19khf13GRb9oz08mMDH7Tv0HVpSKXjs5Mo6SseoyUlQ RkUffl1GHN/SvL1Fs9csP2/wtlj9RheWnt90gU35xrVzovSBHu07KkVNfyqH2o/LNuW d9ZdeMkzqR9XJlSMvl7rq0VJZXimf/e1fsu3drc76sJSMsHw9okGOXX2b0wHUd JzkY4D7poBGHGVlNVOliFDhsgV/31Xftixx11RGtjqlx 2 Vtsf8IKS/3UCTLzt3PkQnmP7Gj7TPYc/o 7Jj8NY38szeOmSGXvENnyx/fl0M4v3DWFkU9YZs eLR988IG7dBHjb4U6xrTKsQmLpLejTeSLTSJnz7hrAoBt2/dLb8Uw WrsLCnv6ZahX2fslAC2 uWHbf6Wgj833XSTbN682V0KBpo9LUtmy/7TbbJq z kvavDXTMw2HbX4b1SU1Mt182dLn3/65UT zMRWoHMmjVL3nvvPXfpu4wfP14OHTrkLl3EaOctLt6X4xdI36FPRI7udEtDkNkXNmALNouNrX75 YZu/afUHonL9b2bJ3/dslvd3Z449JNgXNmALNpPAmLAgzDxRf4vIwS0inUfd0gjARsYWbMJ2sbDVLz9s8zet/qD5M/VXM5wo5cCJw25peGADtmATtuPGmLCg7dp3KtNmNXHxFBlbsAnbxcJWv/ywzd 0 oM lb0nvzAiKujUbZ7Q6NiCTdiOGyPCgl52dIhFCjP9yNiEbdSRNLb65Ydt/qbVH7z9QUdtlOaPAqLy6 tvlXlNN0jLxGbHJmyjjjgxIizOqzv0sscEbKOOpLHVLz9s8zet/uCVMt7 REWJSteBDlm1/F1pnXKdE7nANuqIk8jCgo M8D1A4Fd3YcjYRh2oKyls9csP2/xNqz/oXMV3KkFfKfuhi8qa5X RxluvlVOdp2XfsQOObdQRZ0duZGHBl4vOR0YxgzpQV1LY6pcftvmbVn/wRS0 fotCrqjMX/ZLqb5qhLzz8drsx3SoA3XFRWRhwefQzpeLcZOpw6krIWz1yw/b/E2rP/hMH1/UhiWIqADUgbriIrKwOGMs8Dl03GTqyB3PESe2 uWHbf6m1R M/cFn mEIKioAdeSOMzKJkc7b7BiLOEmijlxs9csP2/xNqT 5IoAOV4hGPgoRFeBVZhIzwkIIiQW8IsarYoiGn7gUKipJYEZYMBo0bpKoIxdb/fLDNn9T6o8SEEQqeEWMV8UQDS9xCSsqfiJlisjCgrwVzhDzuMnU4dSVELb65Ydt/qbVH RTQeoDgFfDeEWMV8UQjVxxCSsqAHWgrriILCxIhoO8FbGTqcOpKyFs9csP2/xNqz9I0oR8KgDiAJGAWEA0dHGprRkVWlQA6kBdcRFZWJBhC8lw4gZ1oK6ksNUvP2zzN63 IPMbkjQp/MRl8ZxFoUUFoA7UFReRhQVp 5BhC8lwYgOJdjJ1JJny0Fa//LDN37T6g3SSyPyGJE0KL3H5ZOXm0KIC26jDVOpKL4x03iJtHzJsxQVso46ksdUvP2zzN63 IJ0kMr/p5IoL0k2GERUA26gjTowIC3KBIm2f1E11SwySsQnbxcifaqtfftjmb1r9gWggneScxhluST 6uCz5/dJQogKbsB01D 5AGBEWgFygZSMzYWdNf4 2ETK2YBO2i4Wtfvlhm79p9Qc5aieNniBX1Y51S/pR4nLiQkfBogJbsAnbcWNMWJBguPbQOpHxM81cRNjI2ILNYiZjttUvP2zzN63 IPH1zj9/Igun/cxTXP768fqCRQW2YDNsUu1CMCYsYMTxzXL5wdVSVp8J4aKEn5l9YQO2YLPY2OqXH7b5m1Z/0Ln68Z82yc8bWr/XLCoE7AsbsBVnh62O8Sz9yF5 ydkT8m3d9dI38moR5MQ4G/B9OXrZx7fID4bVyJX735Gak8mchCDY6pcftvlbCv6EydKPrPpnDnfINS1N0lg/UXqkN3Cmfrz9ueUnrTKqskY2/WGD7NsULsIKk6Wf/7AsBLb65Ydt/hbLHxv/YZnf/xXiv1iNgK1WGbv0n7Y O/WC2qsBBCzAlL0oQRFqOdt4QQAigshBDjUFgIIcahsBBCjENhIYQYh8JCCDEOhYUQYpyChGX37t3 y9ttvu0sXQfn06dPdpWSJq 7Vq1c7tnOnl19 2d0ifeT6Esd5e/zxxx3bhX66bopcH3E8hYBzgv2KdT vWbNGtmzZ4kyYDwq2b25udpf8Wb58eda Pr366qvuFmYoOGKZOnWqLFmyxF2ylwULFkhjY6MzgbvvvtuZv//53ltKL8ePPNN Wll15yS82xcOFCefrpp6W1tdUtSR7lI45j8eLFbqk/upB8 umnzr74myQQBfzA161bJzNnznSmRx99VB566CFnPdYFEY6BWLZsWdY phdeeMEpX7p0qfPXFAULC27I67z10iaeWpp56S4cOHG38yw aePaWRDuKNN95w/hYr iiExx57TFauXCnPP/ 8WyKyY8eO7yzHwT333OPUa5qChQXh2cGDB8WvSaBCSa9QFMtoSuGvWkb0o2 rQmlMeh1608SrOZYUqn78BX7HheUgvhQaqscFjkX3K9919FuHefD6669nz4W rd48wrLfeTR1TmDnzJkz2ejD61qp vVjRpkSI3U8aj/9Our3LsrxV 1XCIhExo0b5ysiiFbAK6 8km2yqOaLWufFQE0pNIu6urpiEa9Qnbd33nmnzJs3z/MkIrxGVINwEiEpQlF9u46ODmedAuv1sLWpqSm7jDoUetMEzbEwF9AUug/5juvGG290ynVf1M2u9kHkUAzwQ8ADQg/5db/yXUe/dWpflOEeAdhWNU1WrVqV/fECVZ/pcwKRwI8c519vknldK8wD/Zhz8bqOAJG7Og9RmDRpknR2drpL3wdNFnDvvfd p8ly vTp7LpCgZhhnA98ioNQwgJwQjGoSgcKjlBY3Ri4aXHzzp8/31kGr732mjvXD wAFbY 99xzzt/cMFZ/aoCGhgbnbzHQfch3XGrglu4LniK4qfUnX5KoH920adOcH5qO8ivfdQxyjRVqW1UnBAjLClWf6XM CkcCEXCE6Ye8hr sI34A6D1H63vbu3Ss1NTXuUnDeeustd 4id9xxhxPFYIJNNa/6ahRoemHwIJpbcRBaWNQJxcWKQpD2OC6kimww4elWCoQ5LvwQ1RMON7i6QZNCRQ/6kzxO9EgEU66YgTjOCWxu2LAhK1aleg8B/LgRseTMOwYsWKbMcsbKp5vbmDJlB1dbXTkRsXoYUFQMlxsRRK0ZXY4GLiqVHIazMv8GTBUxGop2 ApEOW48ITDjR82lI2TfNexkGuMbXFOgj58TJ8T2FNN9oGuVdDoRaF8UyIY9QGLt0G33367E3EoM K LDZpMUVFNoNyWg2kiCYt6KujgiQixwZMHITDacNguCriICOtgE7ZL5WkT5rhwA2J7TLjpS/X1db7rWMg1xjq1LSa9j0UR5znB/Yl nnzXaufOnU7TwOvY8oFmPPaDTfQNRgERBfpQHnzwwWzzBUKjIo1du3Y56wr53sSreYrjBXo9mEx/x8JET4QYAFERRFY16bxgoidCSEE8/PDD2aYWobAQEhp8l6OacHir5dUxPVihsBASErxZU2 Z8jWBBiMUFkKIcSgshBDjUFgIIcYxJizowPL7DkAfoIVJzRcDDETDlIt TMU8PtMMNn/Tgv4NCaYoX91if7 UCvnW RFmn1yMRiy5g/AUGJeiwIdU6OiK tFcGHBs EgKk4kfUtI/yELrG2z pg18EOf1yb0NGBUWfMGI/A46 KqyVN7v49i2b9/uTLnHaSODzV9SOhgVFgyL14eVAww5R7mO/iTCvP5Jtz7CVc fEXUsBkDkhDESCPX0KCofOE51DPpxYB7ga0s9jwfGjujb vmm283NU K1D aBXt9ADDZ/bQDXCs0i/MWEAYMKDDBU5bmf4N98882eigeaO20cd26eVxaKUWHBSGVELepmVAO0ME4jH0nkLVHHgiaYOh5V lo9Cco8ArFe YN4vv0y PCVe58OvPj8Gm79pBImb1A9a79NoaWlxmkdIG4lP5hUYlKiaTjjPXvugeYV9vPpInnnmmWzzC4M elTihHFnkUG4Ko8ICcNPgRgHIf/rhhx868/lIIm8JjgVNAgXmUZYP/BAxgjVI7hFFkPwyyi6exngy4wepj7b1Oh FMtj8TSN6H4ueFwUCCxChACUSeiQD9NHOah/YaWtrcyIYHYgS tqUmGGAI5bVaGrVx2MqlYJxYVE3ByIODKcPG2ngplZPLdyMQZ62 YBI4WkIW5gwjzLTBM33qkdjmEx/Dj7Y/LUdiAvEQAlRvoxzfuj5WTDpKRpMY1xYAKIUPJX0J2ZYTOTogMjhyavf2JhQppptXugiCfAkzc09 UmgeDwC7eGLnq9uPIPUNNn8HA4hOEIkAFX3o3HXXXc5frEP 3PXr1zvLCkQ/2Cf3tbYqVyIT5bW3TizCgigFT6goeTVwE pP2yi20DTzapKhTDXb/FD9DDgOhPIIORFNgbB5PADsKLuYgtgIWt9g8zet6H0sA3WaQgCQ9U01Y3Ijlssuu8xZhzwr6C/xSjmJPhvsq pUfSzYXuVnmTJlilMWFeZjISQhmI FEEIiQGEhhBiHwkIICY1XMwhQWAghxqGwEEKMQ2EhJCHwiriqqspdSgdhj5fCQkhCbNy4USZOnO gupQOMScr92C4IFBZCEmLbtm3OUIao/9wsCRCp4Dgxbd261S0NDj QIyRBKioqnBQWixYtcktKEzTbMA5s7dq10t3d7ZYGh8JCCDEOm0KEEONQWAghxqGwEEKMQ2EhhB iHwkIIMQ6FhRBiHAoLIcQ4FBZCiHEoLIQQ41BYCCHGobAQQoxDYSGEGIfCQggxDoWFEGIcCgshx DgUFkKIcSgshBDjUFgIIcYpb29vl56eHneREEKiIvJ/0ds5zMKKhhIAAAAASUVORK5CYII=
31756
These are toggle buttons that are updated on demand and if the ribbon is not loaded (or loaded correctly), clicking either of these buttons crashes Excel. There are other buttons as well on the same ribbon that work without issue when clicked, it's just these buttons that cause it to crash.
I always insert the URL in my projects for where I get my code help from, unfortunately the link I copied for these bits of code was terribly wrong (which I learned about today, after all these years)
Sub RibbonOnLoad(ribbon As IRibbonUI)
Public myRibbon As IRibbonUI
Public MyTag As String
Public PressedState As Boolean
Public blnCtrlZ As Boolean
'Callback for customUI.onLoad
Sub RibbonOnLoad(ribbon As IRibbonUI)
Set myRibbon = ribbon
If Not StoreObjRef(myRibbon) Then Beep: Stop
If ThisWorkbook.Sheets("Sheet1").ProtectContents = False Then
Sheets("HD").Range("E1").Value = True
blnCtrlZ = True
End If
End Sub
Sub GetPressed(control As IRibbonControl, ByRef returnedVal)
returnedVal = blnCtrlZ
End Sub
Sub GetVisible(control As IRibbonControl, ByRef visible)
'Stop
Dim rngProofer As Range, rngTranscriber As Range
'-x--- ver 3.5.3 - Jul 3, 2020
If CreateObject("WScript.Network").userdomain = "DomainName" Then
Set rngProofer = ThisWorkbook.Sheets("HD").Range("ProofName").Find(LCase(Environ("Username")))
Set rngTranscriber = ThisWorkbook.Sheets("HD").Range("TransName").Find(LCase(Environ("Username")))
Else
If strEnvironUsername <> vbNullString Then
Set rngProofer = ThisWorkbook.Sheets("HD").Range("ProofName").Find(LCase(strEnvironUsername))
Else
Set rngTranscriber = ThisWorkbook.Sheets("HD").Range("TransName").Offset(0, 1).Find(LCase(TransCr))
End If
End If
'-x--- ver 3.5.3 - Jul 3, 2020
If LCase(Environ("Username")) = "abc" Or _
ElseIf Not rngProofer Is Nothing Then
MyTag = "Proofers"
ElseIf Not rngTranscriber Is Nothing Then 'ver 3.2.4 - 2/24/2017
MyTag = "Transcribers"
End If
If control.Tag Like MyTag Then
visible = True
Else
visible = False
End If
End Sub
Sub RefreshRibbon(Tag As String)
MyTag = Tag
If myRibbon Is Nothing Then
MsgBox "Error, restart your workbook"
Else
myRibbon.Invalidate
End If
End Sub
Sub GetLabel(control As IRibbonControl, ByRef label)
Select Case control.id
Case "A01"
Select Case PressedState
Case True: label = "Converted Mins": Sheets("HD").Range("D1").Value = True
Case False: label = "Normal Mins": Sheets("HD").Range("D1").Value = False
End Select
Case "A02"
Select Case PressedState
Case True: label = "Delete Allotment Pane"
Case False: label = "Trans Allotment": Sheets("HD").Range("B1").Value = 1
End Select
Case "A03"
Select Case PressedState
Case True: label = "Delete Allotment Pane"
Case False: label = "Proofers Allotment": Sheets("HD").Range("B1").Value = 2
End Select
Case "A04"
Select Case PressedState
Case True: label = "Rating"
Case False: label = "Rating"
End Select
Case "A05"
' If Sheets("HD").Range("F1").Value = 0 Then
' PressedState = True
' End If
Select Case blnCtrlZ 'Sheets("HD").Range("E1").Value
Case True: label = "Ctrl+Z Enabled"
Case False: label = "Ctrl+Z Disabled"
End Select
End Select
End Sub
'Note: I use two of the 1871 Built-in buttons in this example
Sub GetImage(control As IRibbonControl, ByRef image)
Select Case control.id
Case "A01"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A02"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A03"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A04"
Select Case PressedState
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
Case "A05"
Select Case blnCtrlZ
Case True: image = "PersonaStatusOnline"
Case False: image = "PersonaStatusOffline"
End Select
End Select
End Sub
The ObjStore is run in a separate module as such:
Option Explicit
Public Const C_OBJ_STORAGENAME As String = "thisWorkbook_IRibbonUI_Ptr"
'Added PtrSafe - 12th July 2020 reverted on Jul 24
Declare PtrSafe Function CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal length As Long)
Public Function StoreObjRef(obj As Object) As Boolean
' Serialize and savely store an object reference
StoreObjRef = False
' Serialize
'Changed to LngPtr 12th July 2020
Dim longObj As Double 'LongPtr
longObj = ObjPtr(obj)
' Store into a defined name
If IsNumeric(Range(C_OBJ_STORAGENAME)) Then
Range(C_OBJ_STORAGENAME) = longObj
'Debug.Print "Save storage """; C_OBJ_STORAGENAME; """ stored the object reference"; longObj
End If
' Return
StoreObjRef = True
End Function
Public Function RetrieveObjRef() As Object
' Retrieve from save storage, deserialize and return the object reference
' stored with StoreObjRef
Set RetrieveObjRef = Nothing
' Retrieve from a defined name
Dim longObj As Double
If IsNumeric(Range(C_OBJ_STORAGENAME)) Then
longObj = Range(C_OBJ_STORAGENAME)
'Debug.Print "Object reference"; longObj; "retrieved from save storage """; C_OBJ_STORAGENAME; """"
' Deserialize
Dim obj As Object
CopyMemory obj, longObj, 4
' Return
Set RetrieveObjRef = obj
Set obj = Nothing
End If
End Function
Private Sub use_NameWithoutRef()
' Just demonstrate how a name with no reference would be used
Const C_OBJ_STORAGENAME_NOREF As String = "foo"
Dim aName As Name, longObj As Double
' On each access check if the name exists.
' If not, create it with no reference to a cell and value 0
With ThisWorkbook
On Error Resume Next
Set aName = .Names(C_OBJ_STORAGENAME_NOREF)
On Error GoTo 0
If aName Is Nothing Then
Set aName = .Names.Add(Name:=C_OBJ_STORAGENAME_NOREF, RefersTo:=0)
End If
End With
' store some Long under that Name
longObj = Timer
aName.Value = longObj ' Value is "=4711"
'Debug.Print "Save storage """; C_OBJ_STORAGENAME_NOREF; """ stored the object reference"; longObj
' retrieve some Long from that Name
longObj = Mid(aName.Value, 2)
'Debug.Print "Object reference"; longObj; "retrieved from save storage """; C_OBJ_STORAGENAME_NOREF; """"
End Sub
Public Function ReloadRibbon(Optional id As String = "") As Boolean
' Force the ribbon UI to reload so that states are refreshed.
' This is done by an Invalidate or InvalidateControl(id)
' Returns True if successful
ReloadRibbon = False
' Invalidate the ribbon UI so that everything gets reloaded
If Not (myRibbon Is Nothing) Then
' Invalidate will force the UI to reload and thereby ask for current states
If Len(id) > 0 Then
myRibbon.InvalidateControl id ' Note: This does not work reliably
Else
myRibbon.Invalidate
End If
ReloadRibbon = True
Exit Function
Else
' The static guiRibbon-variable was meanwhile lost.
' We try to retrieve it from save storage and retry Invalidate.
On Error GoTo GiveUp
Set myRibbon = RetrieveObjRef()
If Len(id) > 0 Then
myRibbon.InvalidateControl id ' Note: This does not work reliably
Else
myRibbon.Invalidate
End If
On Error GoTo 0
ReloadRibbon = True
Exit Function
GiveUp:
MsgBox "Due to a design flaw in the architecture of the MS ribbon UI you have to close " & _
"and reopen this workbook """ & ThisWorkbook.Name & """." & vbNewLine & vbNewLine & _
"Very sorry about that." & vbNewLine & vbNewLine & _
"You will then have no problems anymore." _
, vbExclamation + vbOKOnly, ThisWorkbook.Name & ".ReloadRibbon"
' Note: In the help we can find
' guiRibbon.Refresh
' but unfortunatly this is not implemented.
' It is exactly what we should have instead of that brute force reload mechanism.
End If
End Function
So all this code has been working perfectly and without issue from nearly 2017, but it fails on my new PC, and I'm at my wit's end to try to understand why and where it is failing. The code runs successfully every time even on Win 7 + Office 2010 (32 bit). Hoping someone can give me a nudge in the right direction to get this issue sorted.
I have even tried repairing my Office installation, uninstalled and reinstalled Office, but it still fails to load sometimes. Any help is appreciated
Regards,
Lincoln