Excel 2007 To 2010 Ribbon Dynamic Menu Content Using VBA To Display MRU Most Recent

[Excel Fox]

Option Explicit
Dim objRib                      As IRibbonUI
Dim strControlID                As String
Dim strMessage                  As String
Dim varArrayValues              As Variant
Dim varArrayTypes               As Variant
Dim lngSht                      As Long
Dim objSh                       As Object
Const lngMaxList                As Long = 50
Const strTitle As String = "ExcelFox Solutions"
Const strPathKey As String = "HKEY_CURRENT_USER\Software\Microsoft\Office\FavFol\Fol "

'Callback for rxLst, rxFol, rxFav getContent
Sub rxDynMenuGetContent(control As IRibbonControl, ByRef returnedVal)
 
    Dim xml As String
    Dim lng As Long
    lngSht = Empty
    
    If IsArray(varArrayTypes) Then Erase varArrayTypes
    If IsArray(varArrayValues) Then Erase varArrayValues
    If control.ID = "rxLst" Then
        GetRecentFiles False
        For lng = 0 To UBound(varArrayTypes)
            xml = xml & "<button id=""dynSubMenu" & lng &  """ imageMso=""" & ImageName(CStr(varArrayTypes(lng))) & """  tag=""" & XMLParse(CStr(varArrayValues(lng))) & """ label="""  & GiveFile(CStr(varArrayValues(lng))) & """ screentip=""" &  XMLParse(CStr(varArrayValues(lng))) & """  onAction=""FileCustomOpen""/>" & vbLf
        Next lng
    ElseIf control.ID = "rxFol" Then
        GetRecentFiles False
        Call BubbleSort(varArrayValues)
        'For lng = UBound(varArrayValues) To Application.Max(0, UBound(varArrayValues) - lngMaxList) Step -1
        For lng = UBound(varArrayValues) To LBound(varArrayValues) Step -1
            If InStr(1, xml, """" & GiveFolder(CStr(varArrayValues(lng))) & """") = 0 Then
                xml = xml & "<button id=""dynSubMenu" & lng  & """ imageMso=""MenuPublish"" tag=""" &  GiveFolder(CStr(varArrayValues(lng))) & """ label=""" &  GiveFolder(CStr(varArrayValues(lng))) & """  onAction=""FileCustomOpen""/>" & vbLf
            End If
        Next lng
    Else 'rxFav
        GetFavFolders
        xml = xml & vbLf & "<button id=""btnAddFavFol"""
        xml = xml & vbLf & "label=""Add Favorites"""
        xml = xml & vbLf & "imageMso=""CustomActionsMenu"""
        xml = xml & vbLf & "onAction=""AddFavorites""/>" & vbLf
        If IsArray(varArrayTypes) Then
            For lng = UBound(varArrayTypes) To Application.Max(0, UBound(varArrayTypes) - lngMaxList) Step -1
                If InStr(1, xml, """" & varArrayValues(lng) & """") = 0 Then
                    xml = xml & "<splitButton id=""splButton" & lng & """>"
                    xml = xml & vbLf & "<button id=""btnFavFol" & lng & """"
                    xml = xml & vbLf & "label=""" & varArrayValues(lng) & """"
                    xml = xml & vbLf & "tag=""" & varArrayValues(lng) & """"
                    xml = xml & vbLf & "imageMso=""MenuPublish"""
                    xml = xml & vbLf & "onAction=""ToOpenPath""/>"
                    xml = xml & vbLf & "<menu id=""mnu" & lng & """ itemSize=""normal"">"
                    xml = xml & vbLf & "<button id=""btnOpenFolder" & lng & """"
                    xml = xml & vbLf & "label=""Show"""
                    xml = xml & vbLf & "tag=""" & varArrayValues(lng) & """"
                    xml = xml & vbLf & "imageMso=""VisibilityVisible"""
                    xml = xml & vbLf & "onAction=""ToOpenPath"" />"
                    xml = xml & vbLf & "<button id=""btnRemoveFolder" & lng & """"
                    xml = xml & vbLf & "label=""Remove"""
                    xml = xml & vbLf & "tag=""" & varArrayValues(lng) & """"
                    xml = xml & vbLf & "imageMso=""VisibilityHidden"""
                    xml = xml & vbLf & "onAction=""ToRemovePath"" />"
                    xml = xml & vbLf & "</menu>"
                    xml = xml & vbLf & "</splitButton>" & vbLf
                End If
            Next lng
        End If
    End If
    
    xml = "<menu  xmlns=""http://schemas.microsoft.com/office/2006/01/customui"" title="""  & strTitle & """>" & vbLf & _
          xml & "</menu>"

    returnedVal = xml
    On Error Resume Next
    lngSht = ActiveWorkbook.Sheets.Count
    Err.Clear: On Error GoTo 0: On Error GoTo -1
    If lngSht > 0 Then
        objRib.InvalidateControl control.ID
    End If
    strControlID = control.ID
    
End Sub

'Callback for btnFavFol0 onAction
Sub AddFavorites(control As IRibbonControl)

    Dim strPath As String
    Dim lng As Long
    
    If IsArray(varArrayValues) Then
        lng = UBound(varArrayValues)
    Else
        lng = -1
    End If

    strPath = InputBox("Enter folder path here", "Chronos Twelve")
    If strPath <> "" Then
        If FolderShouldBeAdded(strPath) Then
            RegKeySave strPathKey & lng + 2, strPath
        Else
            MsgBox strMessage, vbOKOnly + vbInformation, "Chronos Twelve"
        End If
    End If
    objRib.InvalidateControl "rxFav"
    
End Sub

'Callback for btnFavFol1 onAction
Sub ToOpenPath(control As IRibbonControl)

    Shell "explorer.exe """ & control.Tag & """", 3 'vbMaximizedFocus
    
End Sub

'Callback for btnRemoveFolder1 onAction
Sub ToRemovePath(control As IRibbonControl)

    Dim lngLoop As Long
    Dim lngCounter As Long
    
    GetFavFolders
    RegKeyDelete "HKEY_CURRENT_USER\Software\Microsoft\Office\FavFol\"
    RegKeySave "HKEY_CURRENT_USER\Software\Microsoft\Office\FavFol\", "Chronos Twelve"
    For lngLoop = 0 To UBound(varArrayValues)
        If varArrayValues(lngLoop) <> control.Tag Then
            lngCounter = lngCounter + 1
            RegKeySave strPathKey & lngCounter, CStr(varArrayValues(lngLoop))
        End If
    Next lngLoop
    objRib.InvalidateControl "rxFav"

End Sub

Sub GetRecentFiles(Optional blnExcludeHostApplication As Boolean = True)
 
    Dim lngLoop                 As Long
    Dim lngApps                 As Long
    Dim lngArrayLoop            As Long
    Dim strRegistryPath         As String
    Dim strKeyValue             As String
    Dim strApps                 As Variant
    Dim strVers                 As Variant
    Dim objDic                  As Object
    Dim strString               As String
    
    Set objDic = CreateObject("Scripting.Dictionary")
    strApps = Array("Access", "Word", "Excel", "PowerPoint")
    strVers = Array("10.0", "11.0", "12.0", "14.0")
    For lngApps = 0 To UBound(strApps)
        For lngArrayLoop = 0 To UBound(strVers)
            If Not (blnExcludeHostApplication And strApps(lngApps) &  strVers(lngArrayLoop) = Replace(Application.Name, "Microsoft ", "")  & Application.Version) Then
                strRegistryPath =  "HKEY_CURRENT_USER\Software\Microsoft\Office\" &  RegiPath(CStr(strApps(lngApps)), CStr(strVers(lngArrayLoop)))
                On Error Resume Next
                For lngLoop = 1 To lngMaxList 'Because Office  Applications Until Version 14.0 do not have the feature to record more  than 50 most recently used files
                    strKeyValue = objSh.RegRead(strRegistryPath & lngLoop)
                    If strKeyValue = "" Then
                        Exit For
                    Else
                        If InStr(1, strKeyValue, "*") Then
                            objDic.Add Split(strKeyValue, "*")(1),  CStr(strApps(lngApps)) & " " & CStr(strVers(lngArrayLoop)) &  " " & lngLoop
                        Else
                            objDic.Add strKeyValue,  CStr(strApps(lngApps)) & " " & CStr(strVers(lngArrayLoop)) &  " " & lngLoop
                        End If
                        strKeyValue = ""
                    End If
                Next lngLoop
                Err.Clear: On Error GoTo 0: On Error GoTo -1
            End If
        Next lngArrayLoop
    Next lngApps
    varArrayValues = objDic.Keys
    varArrayTypes = objDic.Items
    Application.StatusBar = False
    Set objDic = Nothing
   
End Sub

Sub GetFavFolders()
 
    Dim lngLoop                 As Long
    Dim strRegistryPath         As String
    Dim strKeyValue             As String
    Dim objSh                   As Object
    Dim objDic                  As Object
    Dim objRegistry             As Object
    Dim varArraySubKeys         As Variant
    Const HKEY_CURRENT_USER = &H80000001
    
    With Application
        strRegistryPath = "Software\Microsoft\Office\FavFol"
    End With
    Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    objRegistry.EnumValues HKEY_CURRENT_USER, strRegistryPath, varArrayValues, varArrayTypes
    If IsArray(varArrayValues) Then
        ReDim varArraySubKeys(UBound(varArrayValues))
        For lngLoop = 1 To UBound(varArrayValues)
            objRegistry.GetStringValue HKEY_CURRENT_USER, strRegistryPath, varArrayValues(lngLoop), varArraySubKeys(lngLoop)
        Next lngLoop
        Set objDic = CreateObject("Scripting.Dictionary")
        On Error Resume Next
        For lngLoop = 1 To UBound(varArraySubKeys)
            objDic.Add CStr(varArraySubKeys(lngLoop)), CStr(varArrayValues(lngLoop))
        Next lngLoop
        Err.Clear: On Error GoTo 0: On Error GoTo -1
        varArrayValues = objDic.Keys
        varArrayTypes = objDic.Items
    End If
    Application.StatusBar = False
    Set objRegistry = Nothing
    Set objDic = Nothing
    Set objSh = Nothing
   
End Sub
Function RegiPath(strApp As String, strVer As String) As String
 
    Select Case Val(strVer)
        Case 10, 11
            Select Case strApp
                Case "Excel"
                    RegiPath = strVer & "\" & strApp & "\Recent Files\File"
                Case "Access"
                    RegiPath = strVer & "\" & strApp & "\Settings\MRU"
                Case "Word"
                    RegiPath = strVer & "\" & strApp & "\Data Settings\MRU"
                Case "PowerPoint"
                    RegiPath = strVer & "\" & strApp & "\Recent File List\File"
            End Select
        Case 12, 14
            Select Case strApp
                Case "Access"
                    RegiPath = strVer & "\" & strApp & "\Settings\MRU"
                Case Else
                    RegiPath = strVer & "\" & strApp & "\File MRU\Item "
            End Select
    End Select
    
End Function
 
'Callback's for the macro's
Sub FileCustomOpen(control As IRibbonControl)
 
    If lngSht = 0 Then
        objRib.InvalidateControl strControlID
    End If
    Shell "explorer.exe """ & control.Tag & """", 3 'vbMaximizedFocus
    
End Sub
 
Private Function ImageName(strType As String) As String
 
    Select Case Left(strType, InStr(1, strType, " ") - 1)
        Case "Excel"
            ImageName = "MicrosoftExcel" '"FileSaveAsExcelXlsx"
        Case "Word"
            ImageName = "FileSaveAsWordDotx"
        Case "PowerPoint"
            ImageName = "MicrosoftPowerPoint" '"FileSaveAsPowerPointPptx"
        Case "Access"
            ImageName = "MicrosoftAccess" '"FileSaveAsAccess2007"
    End Select
    
End Function
 
'Callback for customUI.onLoad
Sub rxLoad(ribbon As IRibbonUI)
 
    Set objRib = ribbon
    'access Windows scripting
    Set objSh = CreateObject("WScript.Shell")
    If RegKeyExists("HKEY_CURRENT_USER\Software\Microsoft\Office\FavFol\") Then
        GetFavFolders
    Else
        RegKeySave "HKEY_CURRENT_USER\Software\Microsoft\Office\FavFol\", "Chronos Twelve"
    End If
 
End Sub
 
Private Function GiveFolder(strPath As String) As String
 
    Dim lng As Long
    
    lng = InStrRev(strPath, "\")
    If lng <> 0 Then
        GiveFolder = Left(strPath, lng)
    Else
        lng = InStrRev(strPath, "/")
        GiveFolder = XMLParse(Left(strPath, lng))
    End If
    
End Function
 
Private Function GiveFile(strPath As String) As String
 
    Dim lng As Long
    
    lng = InStrRev(strPath, "\")
    GiveFile = XMLParse(CStr(Mid(strPath, lng + 1)))
    
End Function
 
Private Function XMLParse(strText As String) As String
 
    XMLParse = Replace(strText, "&", "&amp;&amp;")
    XMLParse = Replace(XMLParse, "'", "&apos;")
    
End Function

Function MatchUp(CityName As String)
    MatchUp = Switch(CityName = "London", "English", CityName _
                    = "Rome", "Italian", CityName = "Paris", "French")
End Function

'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(i_RegKey As String) As String

    On Error Resume Next
    'read key from registry
    RegKeyRead = objSh.RegRead(i_RegKey)
  
End Function

'returns True if the registry key i_RegKey was found
'and False if not
Function RegKeyExists(i_RegKey As String) As Boolean

    On Error GoTo ErrorHandler
    'try to read the registry key
    objSh.RegRead i_RegKey
    'key was found
    RegKeyExists = True
    Exit Function
  
ErrorHandler: 'key was not found
  
End Function

'sets the registry key i_RegKey to the
'value i_Value with type i_Type
'if i_Type is omitted, the value will be saved as string
'if i_RegKey wasn't found, a new registry key will be created
Sub RegKeySave(i_RegKey As String, i_Value As String, Optional i_Type As String = "REG_SZ")

    'write registry key
    objSh.RegWrite i_RegKey, i_Value, i_Type

End Sub

'deletes i_RegKey from the registry
'returns True if the deletion was successful,
'and False if not (the key couldn't be found)
Function RegKeyDelete(i_RegKey As String) As Boolean

    On Error GoTo ErrorHandler
    'delete registry key
    objSh.RegDelete i_RegKey
    'deletion was successful
    RegKeyDelete = True
    Exit Function

ErrorHandler: 'deletion wasn't successful

End Function

Public Function FExist(strFullPath As String) As Boolean

    'Macro Purpose: Check if a file or folder exists
    If InStr(1, strFullPath, "\\Client") > 0 Then
        FExist = True
        Exit Function
    End If
    On Error GoTo EarlyExit
    If Dir(strFullPath, 16) <> vbNullString Then FExist = True
    Exit Function
EarlyExit: Err.Clear: On Error GoTo 0

End Function

Sub Auto_Close()

    Set objSh = Nothing
    
End Sub

Function FolderShouldBeAdded(strPath As String) As Boolean

    FolderShouldBeAdded = True
    If FExist(strPath) = False Then
        strMessage = "Not a valid directory! Please try again."
        FolderShouldBeAdded = False
        Exit Function
    Else
        GetFavFolders
    End If
    If IsNumeric(Application.Match(strPath, varArrayValues, 0)) Then
        strMessage = "This folder already exists in your favorites list!"
        FolderShouldBeAdded = False
    End If
    
End Function

Sub BubbleSort(arr)
    
    Dim strTemp As String
    Dim lngFirst As Long
    Dim lngSecond As Long
    Dim lngMin As Long
    Dim lngMax As Long
    
    lngMin = LBound(arr)
    lngMax = UBound(arr)
    
    For lngFirst = lngMin To lngMax - 1
        For lngSecond = lngFirst + 1 To lngMax
          If arr(lngFirst) < arr(lngSecond) Then
            strTemp = arr(lngFirst)
            arr(lngFirst) = arr(lngSecond)
            arr(lngSecond) = strTemp
          End If
        Next lngSecond
  Next lngFirst

End Sub