View Single Post
 
Old 03-25-2022, 07:44 AM
VBAadvocate VBAadvocate is offline Windows 10 Office 2019
Novice
 
Join Date: Feb 2022
Posts: 12
VBAadvocate is on a distinguished road
Default Custom Ribbon and Callbacks

Here is what I have as an example for a dropdown list. The ribbon xml (use the Custom UI Editor mentioned in Ron de Bruin's website. I am doing this in MS-Word

Ribbon XML:
Code:
<!-- This is ribbon customization -->

<customUI onLoad="rbn_onLoad" xmlns="http://schemas.microsoft.com/office/2009/07/customui">

  <ribbon>
    <tabs>
	
	<!-- Add Custom tab to the ribbon -->
        <tab id="tabDropdownExample" label="My Custom Tab" insertAfterMso="TabDeveloper">
		<group id="grpDropdown" label="Rib Controls">
			<dropDown id="ddDropdown" 
						sizeString="String length is desired control width"
						onAction="RbnOnAction_Dropdown"
						label="Dev Dropdown"
						getSelectedItemIndex="RbnGetSelectedItemIndex_Dropdown"
						getEnabled="RbnGetEnabled_Dropdown"
						getVisible="RbnGetVisible_Dropdown">
				<item id="DropdownDefault" label="My Dropdown:"/>
				<item id="dd1" label="Item 1"/>
				<item id="dd2" label="Item 2"/>
			</dropDown>
			
			<button id="TestButton1" 
				getLabel="RbnGetLabel_TestButton1" 
				size="normal" 
				onAction="RbnOnAction_TestButton1" 
				imageMso="InspectTasksMenu" 
				screentip="Used for testing"/>
		</group>

       </tab>
	<!-- End of Add Custom tab to the ribbon -->
	  
    </tabs>
  </ribbon>

</customUI>
Here are my callbacks:

Code:
Option Explicit
Public Const DblSp As String = vbCrLf & vbCrLf 'Double line space for MsgBox

Public rib As IRibbonUI
Private Const RibPtrName As String = "MyRibbonPtr"

'**** Begin functions to restore the ribbon pointer value
'Credit to Ron de Bruin https://www.rondebruin.nl/index.htm
'with minor changes to store the pointer value in a document variable.
#If VBA7 Then
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#Else
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#End If

#If VBA7 Then
Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
#Else
Function GetRibbon(ByVal lRibbonPointer As Long) As Object
#End If
        Dim objRibbon As Object
        CopyMemory objRibbon, lRibbonPointer, LenB(lRibbonPointer)
        Set GetRibbon = objRibbon
        Set objRibbon = Nothing
End Function

''Word calls this when it loads the file because the RibbonX
'' specified it:  onLoad="rbn_onLoad"
Public Sub rbn_onLoad(ribbon As IRibbonUI)
    'Capture the ribbon variable for later use, specifically to invalidate it.
    'When you invalidate the ribbon Word recreates it.
    Set rib = ribbon
    On Error Resume Next
    ThisDocument.Variables(RibPtrName).Delete
    'Note: variables are typed as strings in Word.
    ThisDocument.Variables.Add RibPtrName, Value:=ObjPtr(rib)
    On Error GoTo 0
    'rib.ActivateTab "tabDropdownExample"
End Sub

Private Sub ShowPointer()
    Dim ptrVal As LongLong
    
    On Error Resume Next
    ptrVal = CLngLng(ThisDocument.Variables(RibPtrName).Value)
    MsgBox "Rib pointer = " & ptrVal
End Sub

'Should be called by an event handler(?) or in a routine to make VBA recreate the ribbon
'Can also be run manually.
Public Sub RedoRib()
    Dim ptrVal As LongLong
    
    On Error Resume Next
    ptrVal = CLngLng(ThisDocument.Variables(RibPtrName))
    On Error GoTo 0
    If ptrVal = 0 Then
        MsgBox "The ribbon pointer is lost.  Ribbon customizations can not be updated." & DblSp _
                & "Unless the ribbon commands you are looking for are missing, " _
                & "everything will still work ok." & DblSp _
                & "Otherwise, save your work, close the file and reopen it to restore " _
                & "ribbon customizations."
        Exit Sub
    End If
    If rib Is Nothing Then
        Set rib = GetRibbon(ptrVal)
        rib.Invalidate
        MsgBox "The Ribbon handle was lost." & DblSp _
        & "Hopefully this is restored now by the GetRibbon function."
    Else
        rib.Invalidate
    End If
    'rib.ActivateTab "tabDropdownExample" 'This works
End Sub
'**** End of functions to restore the ribbon pointer value

'***** Begin callbacks for custom tab id="tabDropdownExample"
'*** Begin callbacks for id="DropDown"
Public Sub RbnOnAction_Dropdown( _
    ByRef ctrl As Office.IRibbonControl, _
    ByRef dropdownID As String, _
    ByRef selectedIndex As Variant)
    
    Dim msg As String
    
    'Note: selectedIndex is zero-based
    'Clicking the default item on control will not trigger this routine.
    Select Case selectedIndex
        Case 0
            msg = "Item 0 selected."
        Case 1
            msg = "Item 1 selected."
        Case 2
            msg = "Item 2 selected."
        Case Else
            msg = "Something weird happened."
    End Select
    MsgBox msg
    RedoRib
End Sub

Public Sub RbnGetSelectedItemIndex_Dropdown( _
    ByRef ctrl As IRibbonControl, _
    ByRef returnedVal As Variant)
    'Note: selectedIndex is zero-based
    'Clicking the default item on control will not trigger this routine.

    returnedVal = 0 'Desired default item to be selected
End Sub

Public Sub RbnGetEnabled_Dropdown( _
    ByRef ctrl As Office.IRibbonControl, _
    ByRef Enabled As Variant)
    
    Const strCase As String = "beEnabled"
    
    Select Case strCase
        Case "beEnabled"
            Enabled = True
        Case Else
            Enabled = False
    End Select
End Sub

Public Sub RbnGetVisible_Dropdown( _
    ByRef ctrl As Office.IRibbonControl, _
    Visible As Variant)
    
    Const blVisible As Boolean = True
    
    If blVisible Then
        Visible = True
    Else
        Visible = False
    End If
End Sub
'*** End of callbacks for DropDown

'***** Begin callbacks for TestButton1
Public Sub RbnOnAction_TestButton1(ctrl As IRibbonControl)
    MsgBox "TestButton1 works."
    RedoRib
End Sub

Public Sub RbnGetLabel_TestButton1( _
   ByRef ctrl As Office.IRibbonControl, _
   ByRef Label As Variant)
   
   Label = "Test Button1"

End Sub

'***** End of callbacks for custom tab id="tabDropdownExample"
Reply With Quote