Adding Custom Ribbon to a Workbook using VBA

[Jerry Sullivan]

Hi all,

I'd like to find a way to add RibbonX code to an existing Excel file (.xlsm) using VBA instead of the Custom UI Editor.

The reason for this is that we have a workbook stored on SharePoint and accessed by many users that occasionally has its Custom Ribbon removed from the file. I've found and prevented one cause of this (users opening the file with Excel Online instead of full Excel), yet the problem has occurred twice since then for no reason that I could find.

I'll continue to try to find the cause, but in the interim, I'm hoping to create a button that anyone can use to restore the Custom Ribbon if it disappears again. Essentially this would programmatically do the same process that the Custom UI Editor does, by merging a saved xml or text file with a closed Excel workbook.

Thanks!

 

[Dryver14]

This might be worth a look Jerry

https://bettersolutions.com/vba/ribbon/document-level-customui-editor.htm

 

[Jerry Sullivan]

Hi Dryver14,

Thanks for the response, however that link just describes how to use the Custom UI Editor, which is the process that I currently use to "manually" add a custom ribbon to the workbook.

My question is asking if anyone knows of an alternative to using the Custom UI Editor that I could setup to allow users to restore a deleted ribbon programmatically, by running a one-click macro.

 

[Dryver14]

No worries I though I saw a section in there that showed how to set the recorded data as a sub from where you could just set the button to reset those original settings

 

[Jerry Sullivan]

In case it will help anyone else, here's some code that I developed for this purpose.

The approach is to store a copy of the RibbonX code text in a worksheet cell. When the RestoreMyRibbon macro is run, it will make a copy of the workbook to which it adds the RibbonX code.

Main Sub:

 Dim msErrMsg As String

'--2007 attributes and namespace
 Const ATT_TARGET_2007 As String = "customUI/customUI.xml"
 Const ATT_TYPE_2007 As String = _
      "http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"
 Const NS_2007 As String = "http://schemas.microsoft.com/office/2006/01/customui"

'--2010 attributes and namespace
 Const ATT_TARGET_2010 As String = "customUI/customUI14.xml"
 Const ATT_TYPE_2010 As String = _
      "http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"
 Const NS_2010 As String = "http://schemas.microsoft.com/office/2009/07/customui"

Public Sub RestoreMyRibbon()
'--restores customUI ribbon to this workbook using ribbonX code stored in
'     cell A1 of sheet with codename wksCustomRibbonBackup
'--process is to copy existing workbook to temp folder. workbook file is
'     unzipped, xml file is written to customUI.xml file, relationships
'     are updated, items are zipped back into workbook which is saved to
'     same folder as source (thisworkbook) with a unique name (using time stamp)

 Dim bSourcePathIsURL As Boolean
 Dim oFSO As Object
 Dim oFile As Object
 Dim sCustomUI_Filename As String, sRibbonXML As String
 Dim sTempFolderPath As String, sTempFilePath As String
 Dim sTargetZipFilePath As String
 Dim sNewWorkbookFolder As String, sNewWorkbookFilePath As String
 
 'On Error GoTo ErrProc
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 
 '--get and validate ribbon xml stored in this workbook
 sRibbonXML = wksCustomRibbonBackup.Cells(1).Value
 
 Select Case True
   '***remove space after < in next line (needed for posting)
   Case Left(sRibbonXML, 16) <> "< customUI xmlns="
      msErrMsg = "Valid XML code for Custom Ribbon not found."
      GoTo ExitProc
  
   Case Mid(sRibbonXML, 18, Len(NS_2007)) = NS_2007
      sCustomUI_Filename = "customUI.xml"
  
   Case Mid(sRibbonXML, 18, Len(NS_2010)) = NS_2010
      sCustomUI_Filename = "customUI14.xml"
  
   Case Else
      msErrMsg = "XML code for Custom Ribbon is unrecognized version."
      GoTo ExitProc
  
 End Select
 
 '--copy workbook to temp dir
 sTempFolderPath = sGetEmptyTempFolder(sTempFolderName:="RestoreMyRibbon")
 If sTempFolderPath = vbNullString Then GoTo ExitProc
 
 sTempFilePath = sTempFolderPath & "\" & ThisWorkbook.Name
 ThisWorkbook.SaveCopyAs (sTempFilePath)
 Set oFile = oFSO.GetFile(sTempFilePath)
 
 '--assign variables for final destination of workbook
 If LCase$(Left(ThisWorkbook.Path, 4)) = "http" Then
   '--if thisworkbook at URL path then target is user's desktop folder
   sNewWorkbookFolder = Environ$("USERPROFILE") & "\Desktop"
 Else
   '--else target is same folder as this workbook
   sNewWorkbookFolder = ThisWorkbook.Path
 End If
 
 sNewWorkbookFilePath = sNewWorkbookFolder & "\" _
   & oFSO.GetBaseName(oFile) _
   & "(with Ribbon)" & Format(Now, " yyyy-mm-dd h-mm-ss") & "." _
   & oFSO.GetExtensionName(oFile)

 '--rename with .zip extension
 oFSO.GetFile(sTempFilePath).Name = oFSO.GetBaseName(oFile) & ".zip"

'--unzip into \Items subfolder
 oFSO.CreateFolder (sTempFolderPath & "\Items")
 Call Unzip( _
   sSourceFilePath:=sTempFolderPath & "\" & oFSO.GetBaseName(oFile) & ".zip", _
   sTargetFolderPath:=sTempFolderPath & "\Items")

'--write custom ribbon xml to file
 Call WriteCustomUI_XML_ToFile(sRibbonXML:=sRibbonXML, _
   sCustomUI_FolderPath:=sTempFolderPath & "\Items\customUI", _
   sCustomUI_Filename:=sCustomUI_Filename)

'--update rels file
 Call UpdateRels(sTopFolderOfItems:=sTempFolderPath & "\Items", _
   sCustomUI_Filename:=sCustomUI_Filename)
 If Len(msErrMsg) Then GoTo ExitProc
 
'--rezip
 sTargetZipFilePath = sTempFolderPath & "\RibbonRestored.zip"
 
 Call Zip(sSourceFolderPath:=sTempFolderPath & "\Items", _
   sTargetFilePath:=sTargetZipFilePath)
 
'--copy file unique name and Excel extension
 oFSO.CopyFile sTargetZipFilePath, sNewWorkbookFilePath
 
 MsgBox "A copy of this workbook with its custom ribbon restored was saved to: " _
   & vbCr & vbCr & sNewWorkbookFilePath

ExitProc:
 On Error Resume Next
 
 '--delete temp files and folder
 If oFSO.FolderExists(sTempFolderPath) Then
   oFSO.DeleteFolder (sTempFolderPath)
 End If
 
 If Len(msErrMsg) Then
   MsgBox msErrMsg, vbCritical
   msErrMsg = vbNullString
 End If
 
 Exit Sub

ErrProc:
 msErrMsg = Err.Number & "-" & Err.Description
 Resume ExitProc
End Sub

Support procedures (paste into same Standard Code Module as Sub):

Private Function sGetEmptyTempFolder(sTempFolderName As String) As String
 '--returns path to empty folder in users temp folder
 Dim sPath As String
 Dim oFSO As Object
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 
 sPath = Environ$("temp") & "\" & sTempFolderName
 
 If oFSO.FolderExists(sPath) Then
   '--delete any files and subfolders in existing temp folder
   On Error Resume Next
   oFSO.DeleteFile sPath & "\*.*", True
   oFSO.DeleteFolder sPath & "\*.*", True
   On Error GoTo 0
 Else
   oFSO.CreateFolder (sPath)
 End If
 
ExitProc:
 If oFSO.FolderExists(sPath) Then
   sGetEmptyTempFolder = sPath
 Else
   sGetEmptyTempFolder = vbNullString
   msErrMsg = "Temporary folder could not be created."
 End If
End Function

Private Sub MakeNewZip(sPath As String)
'--create empty Zip File
 Dim oFSO As Object
 Dim oFile As Object
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")

 Set oFile = oFSO.CreateTextFile(sPath, True)
 oFile.WriteLine (Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0))
 oFile.Close
End Sub

Private Sub Unzip(sSourceFilePath As String, sTargetFolderPath As String)
'--unzips file as source path and copys contents to target folder
'--assumes Source file and Target folder already validated

'--based on code by Ron de Bruin
'  https://www.rondebruin.nl/win/s7/win002.htm

 Dim oApp As Object
  
 'Extract the files into the newly created folder
 Set oApp = CreateObject("Shell.Application")

 oApp.Namespace("" & sTargetFolderPath).CopyHere _
   oApp.Namespace("" & sSourceFilePath).Items

End Sub

Private Sub UpdateRels(sTopFolderOfItems As String, _
   sCustomUI_Filename As String)

'--handle no relationships node?

 Dim oXmlDoc As Object
 Dim oXmlNode As Object, oXmlNewNode As Object
 Dim oXmlNodes As Object
 Dim sRelsFilePath As String, sNS As String
 
 sRelsFilePath = sTopFolderOfItems & "\_rels\.rels"
 
 Set oXmlDoc = CreateObject("Microsoft.XMLDOM")
 oXmlDoc.Load sRelsFilePath
 
 With oXmlDoc.SelectSingleNode("/Relationships")
   sNS = .NamespaceURI
  
   '--remove any existing nodes that would conflict with new relationship
   Set oXmlNodes = oXmlDoc.SelectNodes( _
      "//Relationship[@Id='customUIRelID' or  Target='" _
         & ATT_TARGET_2007 & "' or  Target='" & ATT_TARGET_2010 & "']")

   For Each oXmlNode In oXmlNodes
      Debug.Print "Deleting.." & oXmlNode.Attributes.getNamedItem("Target").Text
      oXmlNode.ParentNode.RemoveChild oXmlNode
   Next oXmlNode

   '--add new node by cloning existing
   Set oXmlNewNode = .ChildNodes(0).CloneNode(True)
   oXmlNewNode.Attributes.getNamedItem("Id").Text = "customUIRelID"
  
   Select Case sCustomUI_Filename
      Case "customUI.xml" '2007
         oXmlNewNode.Attributes.getNamedItem("Type").Text = ATT_TYPE_2007
         oXmlNewNode.Attributes.getNamedItem("Target").Text = ATT_TARGET_2007
     
      Case "customUI14.xml" '2010
         oXmlNewNode.Attributes.getNamedItem("Type").Text = ATT_TYPE_2010
         oXmlNewNode.Attributes.getNamedItem("Target").Text = ATT_TARGET_2010
        
      Case Else
         msErrMsg = "XML filename for Custom Ribbon is unrecognized version."
         GoTo ExitProc
   End Select
  
   .appendChild oXmlNewNode

 End With
 oXmlDoc.Save sRelsFilePath

ExitProc:

End Sub

Private Sub WriteCustomUI_XML_ToFile(sRibbonXML As String, _
   sCustomUI_FolderPath As String, sCustomUI_Filename As String)
 '--creates a new xml file with specified folder and filename
 Dim oFSO As Object
 Dim oFile As Object
 Dim sCustomUI_Filepath As String
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")

 sCustomUI_Filepath = sCustomUI_FolderPath & "" & sCustomUI_Filename

 If oFSO.FolderExists(sCustomUI_FolderPath) = False Then
   oFSO.CreateFolder (sCustomUI_FolderPath)
 End If
 
 Set oFile = oFSO.CreateTextFile(sCustomUI_Filepath, True)
 oFile.WriteLine (sRibbonXML)
 oFile.Close
 
End Sub
  
Private Sub Zip(sSourceFolderPath As String, sTargetFilePath As String)
'--zips all files in source folder and its subfolders. Copies the zip to target file
'--based on code by Ron de Bruin
'  https://www.rondebruin.nl/win/s7/win001.htm

 Dim oApp As Object
 Dim vFileNameZip As Variant, vFolderName As Variant
 
 vFolderName = sSourceFolderPath
 vFileNameZip = sTargetFilePath

 '--create empty zip file
 MakeNewZip (vFileNameZip)

 Set oApp = CreateObject("Shell.Application")
 '--copy the files to the compressed folder
 oApp.Namespace(vFileNameZip).CopyHere oApp.Namespace(vFolderName).Items

 '--keep script waiting until compressing is done
 On Error Resume Next
 Do Until oApp.Namespace(vFileNameZip).Items.Count = _
   oApp.Namespace(vFolderName).Items.Count
   Application.Wait (Now + TimeValue("0:00:01"))
 Loop
 On Error GoTo 0
 
End Sub

 

[Jorgen]

Hi Jerry,
Thank you for the unique and excellent code! It works like a charm for me, except for one tiny snafu. The row in the Sub UpdateRels gives an error on

Set oXmlNodes = oXmlDoc.SelectNodes( _
      "//Relationship[@Id='customUIRelID' or [MENTION=2729]Target[/MENTION]='" _
         & ATT_TARGET_2007 & "' or [MENTION=2729]Target[/MENTION]='" & ATT_TARGET_2010 & "']")

and it says "Unexpected token '['. " and marks the first left [ before the (first) MENTION with two arrows. I don't know the XML object enough to be able to figure out why it is crashing, and my standard method of Trial and Error didn't help me in this case, neither did google.

Could you help me? Where can this knowledge be found? And finally, what does the MENTION=2729 represent?

My usecase is to have a xlam create a new workbook with a custom ribbon, which will not be identical to the one in the xlam, so I expect I will stumble a few more times
Thank you!

//Jörgen

 

[RoryA]

You should remove those tags - they were added by the board software.

 

[Jorgen]

Hi Rory
Thank you for the guidance, that explains why I couldn't find the info anywhere...
I should have noticed that it looks different in the original post vs what I got when I copy/pasted into VBE.

Thanks both!
//Jörgen

 

[RoryA]

I should have noticed that it looks different in the original post

That may be because I edited it to remove those tags. I suspect they were left over from the conversion to the new board software.