Document Level Ribbon Customization using VBA

The other day I participated in a thread at different forum where the OP wants to customize the Word ribbon with VBA. He posted an example that he claimed works in Excel but modified for Word it didn't. I posted a solution there, but that solution (like his for Excel) would write over any application level customization a user might have defined. The thread is found here.

http://www.msofficeforums.com/word-v...ab-ribbon.html

This got me thinking about if something similar could be done at the document level. Now I acknowledge that the following is more an exercise is feasibility than a practical solution because the CustomUIEditor makes this all much simpler. Still, I wanted to see if it could be done and it seems is can in the very clunky way that follows.

The following code is run from a named open Active Document, the result is a new file "Customized_Document Name" with a customized ribbon. The process involves:

1. Making a copy of the active document
2. Converting the copy to a zip format file and opening the zip folder
3. Writing a customUI14.xml file
4. Defining the relationship
5. Zipping up the folder
6. Opening the customized file
6. Closing the original active document.

The chunkiness is the user is left with two files. The original, and the copy with "Customized_" prefixing the original file name.

To replicate you need two standard modules (modMain and MyRibCon) and a class module (clsOpenXMLZipper).

modMain

Code:

---

Option Explicit
Public Sub CustomizeDocumentRibbon()
Dim oDoc As Document
Dim oDocCopy As Document
Dim clsThisZipper As clsOpenXMLZipper
Dim strFileName As String
  Application.ScreenUpdating = False
  Set oDoc = ActiveDocument
  'Make a copy of the active document.
  Set oDocCopy = Documents.Add(oDoc.FullName, , , False)
  oDocCopy.SaveAs2 oDoc.Path & Application.PathSeparator & "Customized_" & oDoc.Name
  strFileName = oDocCopy.FullName
  oDocCopy.Close
  Set clsThisZipper = New clsOpenXMLZipper
  With clsThisZipper
    'Open and unzip the OpenXMLFormat file package.
    .OpenXMLFile = strFileName
    .Un_Zip_XMLContent
    'Create or overwrite the document customUI file.
    If .FolderExists(.OpenXMLFileFolderPath & "XMLContent " & .FileName & "\customUI") Then
      CreateCustomXMLFile .OpenXMLFileFolderPath & "XMLContent " & .FileName & "\customUI"
    Else
      MkDir .OpenXMLFileFolderPath & "XMLContent " & .FileName & "\customUI"
      CreateCustomXMLFile .OpenXMLFileFolderPath & "XMLContent " & .FileName & "\customUI"
      'Now add the relationship to the Rels file
      AddCustUIRelationship .OpenXMLFileFolderPath & "XMLContent " & .FileName & "\_rels"
    End If
    'Zip up the OpenXMLFormat file folders.
    .ZipUp_or_Kill_XMLContent
  End With
  Set clsThisZipper = Nothing
  Application.ScreenUpdating = True
  Documents.Open strFileName
  oDoc.Close
  Stop
  MsgBox "Test"
lbl_Exit:
  Set oDoc = Nothing: Set oDocCopy = Nothing
  Exit Sub
End Sub
Sub CreateCustomXMLFile(strPath As String)
Dim strFileName As String
Dim hFile As Long
Dim strRibbonX As String
  hFile = FreeFile
  strFileName = "customUI14.xml"
  strRibbonX = "<customUI xmlns=""http://schemas.microsoft.com/office/2009/07/customui"">" & vbNewLine
  strRibbonX = strRibbonX + "  <ribbon>" & vbNewLine
  strRibbonX = strRibbonX + "    <tabs>" & vbNewLine
  strRibbonX = strRibbonX + "      <tab id=""custTab1"" label=""My Custom Tab"" insertBeforeQ=""TabDeveloper"">" & vbNewLine
  strRibbonX = strRibbonX + "        <group id=""custGrp1"" label=""My Custom Group"" autoScale=""true"">" & vbNewLine
  strRibbonX = strRibbonX + "          <button id=""custBtn1"" imageMso=""ViewFullScreenView"" onAction=""MyRibCon.ButtonOnAction"" label=""Button 1""/>" & vbNewLine
  strRibbonX = strRibbonX + "          <button id=""custBtn2"" imageMso=""ViewFullScreenView"" onAction=""MyRibCon.ButtonOnAction"" label=""Button 2""/>" & vbNewLine
  strRibbonX = strRibbonX + "          <button id=""custBtn3"" imageMso=""ViewFullScreenView"" onAction=""MyRibCon.ButtonOnAction"" label=""Button 3""/>" & vbNewLine
  strRibbonX = strRibbonX + "        </group>" & vbNewLine
  strRibbonX = strRibbonX + "      </tab>" & vbNewLine
  strRibbonX = strRibbonX + "    </tabs>" & vbNewLine
  strRibbonX = strRibbonX + "  </ribbon>" & vbNewLine
  strRibbonX = strRibbonX + "</customUI>"
  Open strPath & "\" & strFileName For Output Access Write As hFile
  Print #hFile, strRibbonX
  Close hFile
lbl_Exit:
  Exit Sub
End Sub
Sub AddCustUIRelationship(strPath As String)
Dim strBuffer As String, strTemp As String
Dim lngFreeFile As Long
Dim strFileName As String
Dim strCustUIRel As String
  strFileName = strPath & "\.rels"
  lngFreeFile = FreeFile
  Open strFileName For Input As lngFreeFile
  Do Until EOF(lngFreeFile)
    Line Input #lngFreeFile, strBuffer
    strTemp = strTemp & strBuffer & vbCrLf
  Loop
  Close lngFreeFile
  strCustUIRel = "<Relationship Type=""http://schemas.microsoft.com/office/.../extensibility"" Target=""/customUI/customUI14.xml"" Id=""CustUIrID1"" /></Relationships>"
  strTemp = Replace(strTemp, "</Relationships>", strCustUIRel)
  lngFreeFile = FreeFile
  Open strFileName For Output As lngFreeFile
  Print #lngFreeFile, strTemp
  Close lngFreeFile
lbl_Exit:
  Exit Sub
End Sub

---

MyRibCon

Code:

---

Option Explicit
Sub ButtonOnAction(Control As IRibbonControl)
  Select Case Control.ID
    Case "custBtn1": MsgBox "Button 1 executed"
    Case "custBtn2": MsgBox "Button 1 executed"
    Case "custBtn3": MsgBox "Button 1 executed"
  End Select
lbl_Exit:
  Exit Sub
End Sub

---

clsOpenXMLZipper

Code:

---

Option Explicit
Private m_oFSO As Object, m_oShell As Object
Private m_strOpenXMLFileName As String
Private m_strRootPath As String
Public Sub Un_Zip_XMLContent()
  Set m_oFSO = CreateObject("scripting.filesystemobject")
  m_strRootPath = OpenXMLFileFolderPath
  'Define unzip folder
  If Right(m_strRootPath, 1) <> "\" Then
    m_strRootPath = m_strRootPath & "\XMLContent " & FileName & "\"
  Else
    m_strRootPath = m_strRootPath & "XMLContent " & FileName & "\"
  End If
  On Error Resume Next
  'Delete any existing like named folder\files
  m_oFSO.deletefolder m_strRootPath & "*", True
  Kill m_strRootPath & "*.*"
  On Error GoTo 0
  'Create new XMLContent folder.
  If FolderExists(m_strRootPath) = False Then MkDir m_strRootPath
  CustomUI_Images = m_strRootPath & "customUI\images\"
  Set m_oShell = CreateObject("Shell.Application")
  'Copy the OpenXML folders and files to the newly created XMLContent folder.
  m_oShell.Namespace(m_strRootPath).CopyHere m_oShell.Namespace(m_strOpenXMLFileName).items
  On Error Resume Next
  'Clean up temp folder.
  m_oFSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
lbl_Exit:
  Set m_oShell = Nothing: Set m_oFSO = Nothing
  Exit Sub
End Sub
Public Sub ZipUp_or_Kill_XMLContent(Optional bKill As Boolean = False)
Dim varZipTo
Dim lngCount As Long
  Set m_oFSO = CreateObject("scripting.filesystemobject")
  If Not bKill Then
    'To ensure a unique filename, append date and time to the name of the current file
    'sDate = Format(Now, " dd-mmm-yy h-mm-ss")
    varZipTo = m_strOpenXMLFileName & Format(Now, " dd-mmm-yy h-mm-ss") & ".zip"
    'Create empty Zip File
    MakeZip varZipTo
    Set m_oShell = CreateObject("Shell.Application")
    'Count how many items are in the "old" folder
    lngCount = m_oShell.Namespace(OpenXMLFileFolderPath & "XMLContent " & FileName & "\").items.Count
    'Copy the files to the compressed folder
    m_oShell.Namespace(varZipTo).CopyHere m_oShell.Namespace(OpenXMLFileFolderPath & "XMLContent " & FileName & "\").items
    'Loop so script has time to copy files.
    On Error Resume Next
    Do Until m_oShell.Namespace(varZipTo).items.Count = lngCount
      Debug.Print "Nothing of consequence"
    Loop
    DoEvents
    On Error GoTo 0
    Kill m_strOpenXMLFileName
    'Rename new zipped file to same name as original file (with .zip appended)
    Name varZipTo As m_strOpenXMLFileName 'strName
    'Now remove old folder, just in case something went haywire
    m_oFSO.deletefolder OpenXMLFileFolderPath & "XMLContent " & FileName, True
  Else
    On Error Resume Next
    'Now remove old folder, just in case something went haywire
    m_oFSO.deletefolder OpenXMLFileFolderPath & "XMLContent " & FileName, True
    On Error GoTo 0
  End If
  RemoveZipExtension
  Set m_oShell = Nothing
  Set m_oFSO = Nothing
End Sub
Sub MakeZip(strPath)
'Courtesy www.rondebruin.nl
  If Len(Dir(strPath)) > 0 Then Kill strPath
  Open strPath For Output As #1
  Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
  Close #1
lbl_Exit:
  Exit Sub
End Sub
Public Property Let OpenXMLFile(ByVal strFileName)
  m_strOpenXMLFileName = strFileName
  If Not strFileName Like "*.zip" Then
    Name strFileName As strFileName & ".zip"
    m_strOpenXMLFileName = m_strOpenXMLFileName & ".zip"
  End If
End Property
Public Property Get OpenXMLFileFolderPath() As String
  OpenXMLFileFolderPath = Mid(m_strOpenXMLFileName, 1, InStrRev(m_strOpenXMLFileName, "\"))
End Property
Public Property Get FileName()
  If m_strOpenXMLFileName <> "" Then FileName = Mid(m_strOpenXMLFileName, InStrRev(m_strOpenXMLFileName, "\") + 1, Len(m_strOpenXMLFileName))
End Property
Private Sub RemoveZipExtension()
  On Error Resume Next
  Name m_strOpenXMLFileName As Left(m_strOpenXMLFileName, Len(m_strOpenXMLFileName) - 4)
  On Error GoTo 0
lbl_Exit:
  Exit Sub
End Sub
Function FolderExists(ByRef strPath) As Boolean
Dim lngAttribute As Long
  FolderExists = False
  On Error GoTo err_NoFolder
  'Grab the attributes and test for folder bit.
  lngAttribute = GetAttr(strPath)
  If (lngAttribute And vbDirectory) = vbDirectory Then FolderExists = True
lbl_Exit:
  Exit Function
err_NoFolder:
  Resume lbl_Exit
End Function

---

Sample file with all code is attached.

Would be interested if anyone has any ideas on how this might be accomplished where the result is the single original file opene with customization. Everything I have tried falls flat :-(

Thanks