gmaxey
07-29-2017, 10:11 AM
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-vba/36256-adding-tab-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
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/2007/relationships/ui/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
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
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 (http://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
http://www.msofficeforums.com/word-vba/36256-adding-tab-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
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/2007/relationships/ui/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
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
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 (http://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