1. 技术文章
  2. PowerPoint Add-In Loss of RibbonUI

PowerPoint Add-In Loss of RibbonUI

由 断了今生、忘了曾经 提交于 2019-12-01 23:17:34

OK I forgot about this... while I still have not pinpointed the error I have some ideas that users are simply not reporting unhandled runtime errors and instead they're hitting "End" when prompted by PowerPoint.

I'm reasonably certain that is the cause and I have confirmation that in many cases, that sort of error precedes the "crash", so I'm updating to resolve that soon.

Otherwise, here is the method I ultimately have been using for several months, with success.

Create a procedure that writes the Pointer value of the ribbon on the user's machine. I didn't want to do this, but ultimately had to:

Sub LogRibbon(pointer As Long)
    'Writes the ribbon pointer to a text file
    Dim filename As String
    Dim FF As Integer

    filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"

    FF = FreeFile
    Open filename For Output As FF
    Print #FF, pointer
    Close FF

End Sub

In the ribbon's _OnLoad event handler, I call the LogRibbon procedure:

Public Rib As IRibbonUI
Public cbRibbon As New cRibbonProperties
Sub RibbonOnLoad(ribbon As IRibbonUI)
'Callback for customUI.onLoad


    Set Rib = ribbon

    Call LogRibbon(ObjPtr(Rib))

    'Store the properties so we can easily access them later
    cbRibbon.ribbonUI = Rib


End Sub

I created a class object to store some information about the ribbon to avoid repeated and slow calls to an external API, but for this purpose you can create a class that stores just the pointer value. That is referenced above in the cbRibbon.ribbonUI = Rib. This GetRibbon method of this class uses the CopyMemory function from WinAPI to restore the object from it's pointer.

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (destination As Any, source As Any, _
    ByVal length As Long)


'example ported from Excel:
'http://www.excelguru.ca/blog/2006/11/29/modifying-the-ribbon-part-6/
Private pControls As Object
Private pRibbonUI As IRibbonUI
Private pPointer As Long

Sub Class_Initialize()
    'Elsewhere I add some controls to this dictionary so taht I can invoke their event procedures programmatically:
    Set pControls = CreateObject("Scripting.Dictionary")

    Set pRibbonUI = Rib

    Call SaveRibbonPointer(Rib)

    pConnected = False
End Sub


'#############################################################
'hold a reference to the ribbon itself
    Public Property Let ribbonUI(iRib As IRibbonUI)
        'Set RibbonUI to property for later use
        Set pRibbonUI = iRib

    End Property

    Public Property Get ribbonUI() As IRibbonUI
        'Retrieve RibbonUI from property for use
        Set ribbonUI = pRibbonUI
    End Property

'http://www.mrexcel.com/forum/excel-questions/518629-how-preserve-regain-id-my-custom-ribbon-ui.html
Public Sub SaveRibbonPointer(ribbon As IRibbonUI)
    Dim lngRibPtr As Long
    ' Store the custom ribbon UI Id in a static variable.
    ' This is done once during load of UI.

    lngRibPtr = ObjPtr(ribbon)

    cbRibbon.pointer = lngRibPtr

End Sub
Function GetRibbon(lngRibPtr As Long) As Object
    'Uses CopyMemory function to re-load a ribbon that
    ' has been inadvertently lost due to run-time error/etc.
    Dim filename As String
    Dim ret As Long
    Dim objRibbon As Object

    filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"

    On Error Resume Next
    With CreateObject("Scripting.FileSystemObject").GetFile(filename)
        ret = .OpenAsTextStream.ReadLine
    End With
    On Error GoTo 0

    If lngRibPtr = 0 Then
        lngRibPtr = ret
    End If

    CopyMemory objRibbon, lngRibPtr, 4
    Set GetRibbon = objRibbon
    ' clean up invalid object
    CopyMemory objRibbon, 0&, 4
    Set objRibbon = Nothing

End Function


'##############################################################
' Store the pointer reference to the RibbonUI
    Public Property Let pointer(p As Long)
        pPointer = p
    End Property
    Public Property Get pointer() As Long
        pointer = pPointer
    End Property

'#############################################################
'Dictionary of control properties for Dropdowns/ComboBox
    Public Property Let properties(p As Object)
        Set pProperties = p
    End Property
    Public Property Get properties() As Object
        Set properties = pProperties
    End Property

Then, I have a function which checks for loss of ribbon, and restores from the pointer value. This one actually invokes the OnLoad procedure, which we can do since we have an object variable (or class object property) representing the Ribbon object).

Function RibbonError(id As String) As Boolean
'Checks for state loss of the ribbon
Dim ret As Boolean
Dim ptr As Long
Dim src As String

On Error Resume Next

If Not Rib Is Nothing Then
    GoTo EarlyExit
End If

If Rib is Nothing then
    ptr = GetPointerFile
    cbRibbon.pointer = ptr
    Set Rib = cbRibbon.GetRibbon(ptr)
End If
On Error GoTo 0

'make sure the ribbon has been restored or exists:
ret = (Rib is Nothing)

If Not ret then
    'Reload the restored ribbon by invoking the OnLoad procedure
    ' we can only do this because we have a handle on the Ribbon object now
    Call RibbonOnLoad(Rib)
    cbRibbon.pointer = ObjPtr(Rib) 'store the new pointer
Else
    MsgBox "A fatal error has been encountered.", vbCritical
End If

EarlyExit:
RibbonError = ret
End Function

Call on the RibbonError function any time you are going to refresh the ribbon through either Invalidate or InvalidateControl methods.

The code above may not 100% compile -- I had to modify it and trim some stuff out, so let me know if you have any problems trying to implement it!

Found the real solution: Credit

    Public Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (destination As Any, source As Any, _
    ByVal length As Long)

Public Sub ribbon L o a ded(ribbon As IRibbonUI)
   ' Store pointer to IRibbonUI
   Dim lngRibPtr As Long
' Store the custom ribbon UI Id in a static variable.
' This is done once during load of UI. I.e. during workbook open.
    Set guiRibbon = ribbon
    lngRibPtr = ObjPtr(ribbon)
    ' Write pointer to worksheet for safe keeping
    Tabelle2.Range("A1").Value = lngRibPtr
End Sub
Function GetRibbon(lngRibPtr as Long) As Object
   Dim objRibbon As Object
   CopyMemory objRibbon, lngRibPtr, 4
   Set GetRibbon = objRibbon
   ' clean up invalid object
   CopyMemory objRibbon, 0&, 4
   Set objRibbon = Nothing
End Function

Then

    Public Sub DoButton(ByVal control As IRibbonControl)
' The onAction callback for btn1 and btn2

    ' Toggle state
    Toggle12 = Not Toggle12

    ' Invalidate the ribbon UI so that the enabled-states get reloaded
    If Not (guiRibbon Is Nothing) Then
        ' Invalidate will force the UI to reload and thereby ask for their enabled-states
        guiRibbon.Invalidate 'Control ("tabCustom") InvalidateControl does not work reliably
    Else
      Set guiRibbon = GetRibbon(CLng(Tabelle2.Range("A1").Value))
      guiRibbon.Invalidate
        ' The static guiRibbon-variable was meanwhile lost
'        MsgBox "Due to a design flaw in the architecture of the MS ribbon UI you have to close " & _
'            "and reopen this workbook." & vbNewLine & vbNewLine & _
'            "Very sorry about that.", vbExclamation + vbOKOnly
      MsgBox "Hopefully this is sorted now?"
        ' Note: In the help we can find
        ' guiRibbon.Refresh
        ' but unfortunately this is not implemented.
        ' It is exactly what we should have instead of that brute force reload mechanism.
    End If

End Sub
标签
vba
powerpoint-vba
ribbonx
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!