Solved

Count Items on Fluent Ribbon in MS Word / Excel using VBA

Posted on 2014-03-04
7
913 Views
Last Modified: 2014-03-05
Hi All

I would like to count all the items on a custom Ribbon in MS Word or Excel...  Galleries are easy using get item count, but I am wondering if there is a way to count buttons, spin buttons and their menus etc.

I am NOT using the count as part of my ribbon control, I just want to know how many items are on my ribbon.

Example code would be much appreciated!

Kind regards,
0
Comment
Question by:DrTribos
  • 4
  • 2
7 Comments
 
LVL 85

Expert Comment

by:Rory Archibald
ID: 39906457
This will be far from trivial I think. If you look at the article and sample on Tony Jollans' site here: http://www.wordarticles.com/Shorts/RibbonVBA/RibbonVBADemo.php
you will have an idea of what is involved in accessing the Ribbon using Accessibility objects. I don't know of any other way.

I am intrigued as to what you want this for?

Regards,
Rory
0
 
LVL 14

Author Comment

by:DrTribos
ID: 39907413
Thanks Rory,

I hope to use a progress bar while ribbon refreshes.  My progress bar determines percent complete of each process, a count of my ribbon components is the best way I can think of to capture the 100% mark.
0
 
LVL 14

Author Comment

by:DrTribos
ID: 39907427
I could count the occurrances of keywords in the ribbon XML file - do you know if that would be possible on the fly?  I guess worst case scenario is that I HardCode this into my project if an OnTheFly solution can be found...

Note - this is only for my own ribbon, not the built-in ribbons
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 
LVL 14

Author Comment

by:DrTribos
ID: 39907486
There seem to be 2 functions in the demo download from your article that will help, GetAccessible & GetListOfChildren.  That and the IAccessible object.

Not really sure where, how to start though (& just to be helpful my PC can not connect to Office Help at the moment, grrrr).

Any ideas where to start?
0
 
LVL 14

Expert Comment

by:Zack Barresse
ID: 39907822
Hi there,

You can do this by reading the XML of the file. It's a little exhaustive, but doable. I don't know if it would be worth the time/resources to get it though. The process you must go through is basically extracting the XML as text, which means zipping the file, parsing out the XML, unzipping the file.

For extracting XML from a file I use Jan Karel Pieterse's code from here:
http://jkp-ads.com/Articles/Excel2007FileFormat02.asp

In fact most of the code below is his original work, some of it has been altered, but it gets you what you want. I tested this in Excel. It extracts the CustomUI from any file with a CustomUI (tested on Excel and Word files).

First you need a class module. All of this code is by Jan Karel. The class module should be named clsEditOpenXML.
Option Explicit

Private mbCreateBackup As Boolean
Private mvSourceFile As Variant
Private mvXLFolder As Variant
Private msSheet2Change As String
Private msSheetId As String
Private msSheetFileName As String
Private mbAddedZip As Boolean
Private mvUnzipFolder As Variant
Private mvXMLFolderRoot As Variant

Public Enum XMLFolder
    'Date Created : 5/12/2009 21:34
    'Author       : Ken Puls (www.excelguru.ca)
    'Macro Purpose: Constants for XML Containers
    XMLFolder_root = 1
    XMLFolder_rels = 2
    XMLFolder_xl = 3
    XMLFolder_customUI = 4
    XMLFolder_docProps = 5
End Enum

Public Sub CopyFiles2(sFileSpec As String, sSourcePath As String, sTargetPath As String)
    Dim sFile As String
    sFile = Dir(XLFolder & sSourcePath & sFileSpec)
    Do While Len(sFile) > 0
        FileCopy XLFolder & sSourcePath & sFile, sTargetPath & sFile
        sFile = Dir()
    Loop
End Sub

Public Function GetXMLFromFile(sFileName As String) As String
'-------------------------------------------------------------------------
' Procedure : GetXMLFromFile
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Gets the XML code from the foldername\filename
'-------------------------------------------------------------------------
    Dim oXMLDoc As MSXML2.DOMDocument
    If Len(XLFolder) = 0 Then
        GetXMLFromFile = ""
    Else
        Set oXMLDoc = New MSXML2.DOMDocument
        oXMLDoc.Load XLFolder & "customUI14.xml" 'sFileName
        GetXMLFromFile = oXMLDoc.XML
        Set oXMLDoc = Nothing
    End If
End Function

Public Sub WriteXML2File(sXML As String, sFileName As String, sXMLFolder As XMLFolder)
'-------------------------------------------------------------------------
' Procedure : WriteXML2File
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Writes sXML to sFileName
'             Modified by Ken Puls 2009-05-12
'             Adjusted to add ability to write to customUI container
'-------------------------------------------------------------------------
    Dim oXMLDoc As MSXML2.DOMDocument
    Set oXMLDoc = New MSXML2.DOMDocument

    'If attempting to write a customUI component, test to see if one exists
    
    'Should probably test the .rels file to see if the CustomUI relationship exists...
    If sXMLFolder = XMLFolder_customUI Then
        If Not FolderExists(XMLFolder(XMLFolder_customUI)) Then

            MkDir XMLFolder(XMLFolder_customUI)
            'Write the XML to the file
            oXMLDoc.loadXML sXML
            oXMLDoc.Save XMLFolder(sXMLFolder) & sFileName
            'CustomUI has not been created yet.  Rels file needs to be adjusted
            AddCustomUIToRels
        End If
    End If

    'Write the XML to the file
    oXMLDoc.loadXML sXML
    oXMLDoc.Save XMLFolder(sXMLFolder) & sFileName
End Sub

Public Sub AddCustomUIToRels()
'Date Created : 5/14/2009 23:29
'Author       : Ken Puls (www.excelguru.ca)
'Macro Purpose: Add the customUI relationship to the rels file

    Dim oXMLDoc As MSXML2.DOMDocument
    '    Dim oXMLElement As MSXML2.IXMLDOMElement
    Dim oXMLElement As MSXML2.IXMLDOMNode
    Dim oXMLAttrib As MSXML2.IXMLDOMAttribute
    Dim oNamedNodeMap As MSXML2.IXMLDOMNamedNodeMap
    Dim oXMLRelsList As MSXML2.IXMLDOMNodeList
    'Create a new XML document
    Set oXMLDoc = New MSXML2.DOMDocument
    'Attach to the root element of the .rels file
    oXMLDoc.Load XMLFolder(XMLFolder_rels) & ".rels"

    'Create a new relationship element in the .rels file
    Set oXMLElement = oXMLDoc.createNode(1, "Relationship", _
                                         "http://schemas.openxmlformats.org/package/2006/relationships")
    Set oNamedNodeMap = oXMLElement.Attributes

    'Create ID attribute for the element
    Set oXMLAttrib = oXMLDoc.createAttribute("Id")
    oXMLAttrib.NodeValue = "cuID"
    oNamedNodeMap.setNamedItem oXMLAttrib

    'Create Type attribute for the element
    Set oXMLAttrib = oXMLDoc.createAttribute("Type")
    oXMLAttrib.NodeValue = "http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"
    oNamedNodeMap.setNamedItem oXMLAttrib

    'Create Target element for the attribute
    Set oXMLAttrib = oXMLDoc.createAttribute("Target")
    oXMLAttrib.NodeValue = "customUI/customUI.xml"
    oNamedNodeMap.setNamedItem oXMLAttrib

    'Now insert the new node at the proper location
    Set oXMLRelsList = oXMLDoc.SelectNodes("/Relationships")
    oXMLRelsList.Item(0).appendChild oXMLElement
    'Save the .rels file
    oXMLDoc.Save XMLFolder(XMLFolder_rels) & ".rels"

    Set oXMLAttrib = Nothing
    Set oXMLElement = Nothing
    Set oXMLDoc = Nothing
End Sub

Private Function GetSheetIdFromSheetName(sSheetName) As String
'-------------------------------------------------------------------------
' Procedure : GetSheetIdFromSheetName
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Finds out what the SheetId of sSheetname is
'             by reading Workbook.xml
'-------------------------------------------------------------------------
    Dim oXMLDoc As MSXML2.DOMDocument
    Dim oXMLNode As MSXML2.IXMLDOMNode
    Dim oXMLNodeList As MSXML2.IXMLDOMNodeList
    If mvXLFolder <> "" And Sheet2Change <> "" Then
        Set oXMLDoc = New MSXML2.DOMDocument
        oXMLDoc.Load XLFolder & "workbook.xml"
        Set oXMLNodeList = oXMLDoc.SelectNodes("/workbook/sheets/sheet")
        For Each oXMLNode In oXMLNodeList
            If oXMLNode.Attributes.getNamedItem("name").NodeValue = sSheetName Then
                GetSheetIdFromSheetName = oXMLNode.Attributes.getNamedItem("r:id").NodeValue
                Exit Function
            End If
        Next
    End If
End Function

Public Function GetSheetFileNameFromId(sSheetId As String) As String
'-------------------------------------------------------------------------
' Procedure : GetSheetFileNameFromId
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Fetches the name of the xml file belonging to the sheet with id SheetId.
'-------------------------------------------------------------------------
    Dim oXMLDoc As MSXML2.DOMDocument
    Dim oXMLNode As MSXML2.IXMLDOMNode
    Dim oXMLNodeList As MSXML2.IXMLDOMNodeList
    If mvXLFolder <> "" And Sheet2Change <> "" Then
        Set oXMLDoc = New MSXML2.DOMDocument
        oXMLDoc.Load XLFolder & "_rels\workbook.xml.rels"
        Set oXMLNodeList = oXMLDoc.SelectNodes("/Relationships/Relationship")
        For Each oXMLNode In oXMLNodeList
            If oXMLNode.Attributes.getNamedItem("Id").NodeValue = sSheetId Then
                GetSheetFileNameFromId = oXMLNode.Attributes.getNamedItem("Target").NodeValue
                Exit Function
            End If
        Next
    End If
End Function

Public Function GetSheetNameFromId(sId As String) As String
'-------------------------------------------------------------------------
' Procedure : GetSheetNameFromId
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Returns the sheetname belonging to a sheetId
'-------------------------------------------------------------------------
    Dim oXMLDoc As MSXML2.DOMDocument
    Dim oXMLNode As MSXML2.IXMLDOMNode
    Dim oXMLNodeList As MSXML2.IXMLDOMNodeList
    If mvXLFolder <> "" Then
        Set oXMLDoc = New MSXML2.DOMDocument
        oXMLDoc.Load XLFolder & "workbook.xml"
        Set oXMLNodeList = oXMLDoc.SelectNodes("/workbook/sheets/sheet")
        For Each oXMLNode In oXMLNodeList
            If oXMLNode.Attributes.getNamedItem("r:id").NodeValue = "rId" & Val(sId) + 1 Then
                GetSheetNameFromId = oXMLNode.Attributes.getNamedItem("name").NodeValue
                'Got it, get out
                Exit Function
            End If
        Next
    End If
End Function

Public Sub ZipAllFilesInFolder()
'-------------------------------------------------------------------------
' Procedure : ZipAllFilesInFolder
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Zips all files in a folder (including subfolders) whilst retaining the folder structure
'-------------------------------------------------------------------------
    'Courtesy www.rondebruin.nl
    Dim oShellApp As Object
    Dim sDate As String
    Dim sDefPath As String
    Dim vFileNameZip As Variant
    Dim FSO As Object
    Dim lFileCt As Long
    Set FSO = CreateObject("scripting.filesystemobject")
    
    '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")
    vFileNameZip = SourceFile & sDate & ".zip"
    
    'Create empty Zip File
    NewZip vFileNameZip
 
    Set oShellApp = CreateObject("Shell.Application")
    
    'Count how many items are in the "old" folder
    lFileCt = oShellApp.Namespace(FolderName & "Unzipped " & FileName & "\").items.Count
    
    'Copy the files to the compressed folder
    oShellApp.Namespace(vFileNameZip).CopyHere oShellApp.Namespace(FolderName & "Unzipped " & FileName & "\").items
 
    'Keep script waiting until we have same # of files in the new folder
    On Error Resume Next
    Do Until oShellApp.Namespace(vFileNameZip).items.Count = lFileCt
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    DoEvents
    
    'Remove original file
    Kill SourceFile
    
    'Rename new zipped file to same name as original file (with .zip appended)
    Name vFileNameZip As SourceFile
    On Error Resume Next
    
    'Now remove old folder, just in case something went haywire
    FSO.deletefolder FolderName & "Unzipped " & FileName, True
    On Error GoTo 0

    Set oShellApp = Nothing
End Sub

Public Sub UnzipFile()
'-------------------------------------------------------------------------
' Procedure : UnzipFile
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 6-5-2009
' Purpose   : Unzips all files in a zip file to a designated folder
'-------------------------------------------------------------------------
    'Courtesy www.rondebruin.nl
    Dim FSO As Object
    Dim oShellApp As Object
    Set FSO = CreateObject("scripting.filesystemobject")
        
    'Derive the folder to unzip to from the location of the sourcefile
    XMLFolderRoot = FolderName
    
    'A dedicated unzip folder will be created in the same folder as the sourcefile,
    'called ..\Unzipped Filename\
    If Right(XMLFolderRoot, 1) <> "\" Then
        XMLFolderRoot = XMLFolderRoot & "\UnZipped " & FileName & "\"
    Else
        XMLFolderRoot = XMLFolderRoot & "UnZipped " & FileName & "\"
    End If
    On Error Resume Next
    'Remove all previous existing folders
    FSO.deletefolder XMLFolderRoot & "*", True
    Kill XMLFolderRoot & "*.*"
    On Error GoTo 0

    'Create normal folder
    If FolderExists(XMLFolderRoot) = False Then
        MkDir XMLFolderRoot
    End If
    XLFolder = XMLFolderRoot & "customUI\"
    Set oShellApp = CreateObject("Shell.Application")
    'Copy the files in the newly created folder
    oShellApp.Namespace(XMLFolderRoot).CopyHere oShellApp.Namespace(SourceFile).items

    On Error Resume Next
    'Clean up temp folder
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    
    Set oShellApp = Nothing
    Set FSO = Nothing
    Exit Sub
End Sub

Sub NewZip(sPath)
'Courtesy www.rondebruin.nl
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

Public Property Get CreateBackup() As Boolean
    CreateBackup = mbCreateBackup
End Property

Public Property Let CreateBackup(ByVal bCreateBackup As Boolean)
    mbCreateBackup = bCreateBackup
End Property

Private Sub Class_Initialize()
    'Set defaults
    CreateBackup = True
End Sub

Public Property Get SourceFile() As Variant
    SourceFile = mvSourceFile
End Property

Public Property Let SourceFile(ByVal vSourceFile As Variant)
    mvSourceFile = vSourceFile
    If CreateBackup Then
        If Len(Dir(vSourceFile & "(backup)")) > 0 Then
            Kill vSourceFile & "(backup)"
        End If
        FileCopy vSourceFile, vSourceFile & "(backup)"
    End If
    If Not vSourceFile Like "*.zip" Then
        Name vSourceFile As vSourceFile & ".zip"
        mvSourceFile = mvSourceFile & ".zip"
        AddedZip = True
    End If
End Property

Public Property Get FolderName() As Variant
    FolderName = Mid(SourceFile, 1, InStrRev(SourceFile, "\"))
End Property

Public Property Get FileName() As Variant
    If SourceFile <> "" Then
        FileName = Mid(SourceFile, InStrRev(SourceFile, "\") + 1, Len(SourceFile))
    End If
End Property

Public Property Get XLFolder() As Variant
    XLFolder = mvXLFolder
End Property

Public Property Let XLFolder(ByVal vXLFolder As Variant)
    mvXLFolder = vXLFolder
End Property

Public Property Get XMLFolder(sXMLFolder As XMLFolder) As String
    Select Case sXMLFolder
        Case Is = XMLFolder_root
            XMLFolder = mvXMLFolderRoot
        Case Is = XMLFolder_customUI
            XMLFolder = mvXMLFolderRoot & "customUI" & Application.PathSeparator
        Case Is = XMLFolder_docProps
            XMLFolder = mvXMLFolderRoot & "docProps" & Application.PathSeparator
        Case Is = XMLFolder_rels
            XMLFolder = mvXMLFolderRoot & "_rels" & Application.PathSeparator
        Case Is = XMLFolder_xl
            XMLFolder = mvXMLFolderRoot & "xl" & Application.PathSeparator
    End Select
End Property

Public Property Get Sheet2Change() As String
    Sheet2Change = msSheet2Change
End Property

Public Property Let Sheet2Change(ByVal sSheet2Change As String)
    msSheet2Change = sSheet2Change
    SheetId = GetSheetIdFromSheetName(sSheet2Change)
    If SheetId <> "" Then
        SheetFileName = GetSheetFileNameFromId(SheetId)
    End If
End Property

Public Property Get SheetId() As String
    SheetId = msSheetId
End Property

Public Property Let SheetId(ByVal sSheetId As String)
    msSheetId = sSheetId
End Property

Public Property Get SheetFileName() As String
    SheetFileName = msSheetFileName
End Property

Public Property Let SheetFileName(ByVal sSheetFileName As String)
    msSheetFileName = sSheetFileName
End Property

Private Property Get AddedZip() As Boolean
    AddedZip = mbAddedZip
End Property

Private Property Let AddedZip(ByVal bAddedZip As Boolean)
    mbAddedZip = bAddedZip
End Property

Private Sub Class_Terminate()
    Dim FSO As Object
    If AddedZip Then
        'Remove .zip from file again
        Name SourceFile As Left(SourceFile, Len(SourceFile) - 4)
    End If
    'Remove zip folder
    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    'Omit trailing backslash
    FSO.deletefolder Left(UnzipFolder, Len(UnzipFolder) - 1), True
    Set FSO = Nothing
End Sub

Private Property Get UnzipFolder() As Variant
    UnzipFolder = mvUnzipFolder
End Property

Private Property Let UnzipFolder(ByVal vUnzipFolder As Variant)
    mvUnzipFolder = vUnzipFolder
End Property

Private Property Get XMLFolderRoot() As Variant
    XMLFolderRoot = mvXMLFolderRoot
End Property

Private Property Let XMLFolderRoot(ByVal vXMLFolderRoot As Variant)
    mvXMLFolderRoot = vXMLFolderRoot
End Property

Open in new window


Next, in a standard module (named whatever you want), add the following code:
Option Explicit

Public Sub ExtractCustomUI()

    Dim TargetFilePath        As String
    Dim TargetFileName        As String
    Dim cEditOpenXML            As clsEditOpenXML
    Dim DestinationSheet        As Worksheet
    Dim sXML                    As String

    Set cEditOpenXML = New clsEditOpenXML
    
    '///////////////////////////////////////////////////////////////////////////
    '/// ADJUST THE FOLLOWING VALUES
    '///////////////////////////////////////////////////////////////////////////
    Set DestinationSheet = ThisWorkbook.Worksheets("Sheet1") '<- SET SHEET HERE
    TargetFilePath = ThisWorkbook.Path  '<- ADJUST AS NEEDED
    TargetFileName = "TEST.docm" '<- ADJUST AS NEEDED
    '///////////////////////////////////////////////////////////////////////////
    
    With cEditOpenXML
        .SourceFile = TargetFilePath & "\" & TargetFileName
        .UnzipFile
        sXML = .GetXMLFromFile(.SheetFileName)
        WriteXML2Sheet sXML, DestinationSheet
        .ZipAllFilesInFolder
    End With
    
    Set cEditOpenXML = Nothing
    
End Sub

Public Sub WriteXML2Sheet(ByVal sXML As String, ByVal WriteSheet As Worksheet)
    Dim oNode                   As MSXML2.IXMLDOMNode
    Dim oNodeChild              As MSXML2.IXMLDOMNode
    Dim oNodeList               As MSXML2.IXMLDOMNodeList
    Dim oXMLDoc                 As MSXML2.DOMDocument
    Dim lRow                    As Long
    Dim iAttribute              As Long
    Set oXMLDoc = New MSXML2.DOMDocument
    oXMLDoc.loadXML sXML
    Set oNodeList = oXMLDoc.SelectNodes("/customUI")
    lRow = 0
    WriteSheet.Cells.Clear
    'Nodes: CustomUI/Ribbon/Tabs/Tab/Groups
    For Each oNode In oNodeList.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes
        lRow = lRow + 1
        WriteSheet.Cells(lRow, 1).Value = oNode.Attributes(0).BaseName & ":" & oNode.Attributes(0).Text
        WriteSheet.Cells(lRow, 2).Value = oNode.Attributes(1).BaseName & ":" & oNode.Attributes(1).Text
        WriteSheet.Cells(lRow, 1).Font.Bold = True
        lRow = lRow + 1
        For Each oNodeChild In oNode.ChildNodes
            For iAttribute = 0 To oNodeChild.Attributes.Length - 1
                WriteSheet.Cells(lRow, iAttribute + 1).Value = oNodeChild.Attributes(iAttribute).BaseName & ":" & oNodeChild.Attributes(iAttribute).Text
            Next
            lRow = lRow + 1
        Next
    Next
    If lRow > 0 Then
        WriteSheet.Cells.EntireColumn.AutoFit
    End If
End Sub

Open in new window


Set the variables in the ExtractCustomUI() routine. Running it will put just the objects of the custom UI on the worksheet (not including the tab itself). Keep in mind this includes groups and separators as well. Since the separators will only have one attribute per item, we can make a check for those by looking at the Attributes.Length if it is equal to 1.

Instead of listing them out (to answer your original question) if you just want a count of items in the Custom UI, you could use these routines in a standard module (still utilizing the class module above):

Public Sub GetCountOfCustomUI()

    Dim TargetFilePath          As String
    Dim TargetFileName          As String
    Dim cEditOpenXML            As clsEditOpenXML
    Dim DestinationSheet        As Worksheet
    Dim sXML                    As String

    Set cEditOpenXML = New clsEditOpenXML

    '///////////////////////////////////////////////////////////////////////////
    '/// ADJUST THE FOLLOWING VALUES
    '///////////////////////////////////////////////////////////////////////////
    Set DestinationSheet = ThisWorkbook.Worksheets("Sheet1")    '<- SET SHEET HERE
    TargetFilePath = ThisWorkbook.Path  '<- ADJUST AS NEEDED
    TargetFileName = "TEST.docm"    '<- ADJUST AS NEEDED
    '///////////////////////////////////////////////////////////////////////////

    With cEditOpenXML
        .SourceFile = TargetFilePath & "\" & TargetFileName
        .UnzipFile
        sXML = .GetXMLFromFile(.SheetFileName)
        DestinationSheet.Range("A1").Value = CountItemsInXML(sXML)
        .ZipAllFilesInFolder
    End With

    Set cEditOpenXML = Nothing

End Sub

Public Function CountItemsInXML(ByVal sXML As String) As Long
    Dim oNode                   As MSXML2.IXMLDOMNode
    Dim oNodeChild              As MSXML2.IXMLDOMNode
    Dim oNodeList               As MSXML2.IXMLDOMNodeList
    Dim oXMLDoc                 As MSXML2.DOMDocument
    Dim iAttribute              As Long
    Dim iCount                  As Long
    Set oXMLDoc = New MSXML2.DOMDocument
    oXMLDoc.loadXML sXML
    Set oNodeList = oXMLDoc.SelectNodes("/customUI")
    'Nodes: CustomUI/Ribbon/Tabs/Tab/Groups
    For Each oNode In oNodeList.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes
        For Each oNodeChild In oNode.ChildNodes
            If oNodeChild.Attributes.Length > 1 Then
                iCount = iCount + 1
            End If
        Next
    Next
    CountItemsInXML = iCount
End Function

Open in new window


Please note the file cannot be open during this process. If the file is open you should make a copy of it. This can be done in code if you'd like.

PLEASE MAKE A BACKUP OF ALL FILES PRIOR TO TESTING. This renames and deletes files. While working on my computer, it's always a good idea to make a backup of your work prior to testing this code.

HTH

Regards,
Zack Barresse
0
 
LVL 14

Accepted Solution

by:
Zack Barresse earned 500 total points
ID: 39907831
I forgot to add, you must set a reference to Microsoft XML 6.0 (in the VBE, click Tools | References, check the reference, click OK).

Edit: Attached is a sample file with the code already in it.

Zack
EditOpenXML.zip
0
 
LVL 14

Author Comment

by:DrTribos
ID: 39908167
Hi Zack,  Thank you!

I had to add an error control line to ignor some errors, I was getting runtime err 91 - but yes it works - thanks!

    'Nodes: CustomUI/Ribbon/Tabs/Tab/Groups
    For Each oNode In oNodeList.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes.Item(0).ChildNodes
        For Each oNodeChild In oNode.ChildNodes
        
           On Error GoTo skip
           If oNodeChild.Attributes.Length > 1 Then
                iCount = iCount + 1
            End If
skip:
        Next
    Next

Open in new window

0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Microsoft Word is a program we have all encountered at some point, but very few of us have dug deep into its full scope of features, let alone customized it to suit our needs. Luckily making the ribbon (aka toolbar, first introduced in Word 2007) wo…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.
In a previous video Micro Tutorial here at Experts Exchange (http://www.experts-exchange.com/videos/1358/How-to-get-a-free-trial-of-Office-365-with-the-Office-2016-desktop-applications.html), I explained how to get a free, one-month trial of Office …

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now