Results 1 to 2 of 2

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

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10

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

    This is a revised version of the Excel 2007 Chronos Twelve Add-In that displays the most recently used office application files for MS-Access, PowerPoint and MS-Word, apart from the Excel recent files. What I used to like (and still like) about this add-in, is that it also lists MRU files from different versions of installed MS-Office suite. So if you are using two or more versions of MS-Office installed, this will still pick the MRU files. The other feature, ie, listing the most recently used folders, which was already there in Chronos Twelve, has been continued and improved in Chronos Fourteen. The improvement is that the list is now sorted in ascending order.

    For the developers, the XML used hasn't been changed from http://www.excelfox.com/forum/f10/ex...namicmenu-423/. So I'll not post that here.

    The revised code is as below. For the more advanced coders, you'd notice that the ribbon XML is being created via VBA, and that the DynamicMenu control in the ribbon extensibility is being used here.

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg
    https://www.youtube.com/watch?v=v_1iqtOnUMg&lc=UgxLtKj969oiIu7zNb94AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=Ugxq4JHRza_zx3sz0fx4AaABAg
    https://www.youtube.com/watch?v=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg. 9irLgSdeU3r9itU7zdnWHw
    https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htJ6TpIOXR
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg. 9ht16tzryC49htOKs4jh3M
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Attached Files Attached Files
    Last edited by DocAElstein; 10-24-2023 at 02:24 PM.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Code:
    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
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

Similar Threads

  1. Test copy Activate Ribbon Tab In Excel 2007 2010 *
    By Excel Fox in forum Test Area
    Replies: 16
    Last Post: 01-22-2019, 05:05 PM
  2. Excel 2003 Classic Menu in Excel 2007-2010
    By Excel Fox in forum Classic Menu
    Replies: 7
    Last Post: 09-10-2014, 10:29 PM
  3. Ribbon DatePicker Calendar Control For Excel 2007-2010
    By Excel Fox in forum Excel Ribbon and Add-Ins
    Replies: 5
    Last Post: 10-12-2013, 11:23 AM
  4. Ribbon Calendar DatePicker Word 2007-2010
    By Excel Fox in forum Download Center
    Replies: 24
    Last Post: 09-23-2013, 09:07 AM
  5. Replies: 4
    Last Post: 06-07-2012, 09:50 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •