Results 1 to 5 of 5

Thread: Excel 2007 OfficeMenu Addin For Recent Files and Folders Using DynamicMenu

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Grand Master
    Join Date
    Apr 2011
    Posts
    22
    Rep Power
    10

    Excel 2007 OfficeMenu Addin For Recent Files and Folders Using DynamicMenu

    Chronos Twelve.jpg

    Ever wished you could have all your recent Office files' MRU / Most Recently Used / Recent link from Word, PowerPoint and Access in the same place? Office 2010 has the recent folders list in the Backstage view. But how about something similar in Excel 2007, especially with the Win XP, and other pre-Windows 7 releases?

    Chronos Twelve (Chronos=Related to Time (recency); Twelve=Office 12.0) is an Excel based add-in that does just about this. For developers who are interested, I will post both the XML code as well as the VBA code below. This is still in nascent stage of development, and I will add enhancements as and when time permits. Feedback and suggestions are welcome.

    Code:
    Option Explicit
    Dim objRib                      As IRibbonUI
    Dim strControlID                As String
    Dim varArrayValues              As Variant
    Dim varArrayTypes               As Variant
    Dim lngSht                      As Long
     
    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 objSh                   As Object
        Dim objDic                  As Object
        
        Set objSh = CreateObject("wscript.shell")
        Set objDic = CreateObject("Scripting.Dictionary")
        strApps = Array("Excel", "Access", "Word", "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 50 '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
        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 for rxLst, rxFol getContent
    Sub rxDynMenuGetContent(control As IRibbonControl, ByRef returnedVal)
     
        Dim xml As String
        Dim lng As Long
        lngSht = Empty
        
        If control.ID = "rxLst" Then
            GetRecentFiles
            For lng = 0 To UBound(varArrayTypes)
                xml = xml & "<button id=""dynSubMenu" & lng & """ imageMso=""" & ImageName(CStr(varArrayTypes(lng))) & """ tag=""" & ParseXML(CStr(varArrayValues(lng))) & """ label=""" & GiveFile(CStr(varArrayValues(lng))) & """ screentip=""" & ParseXML(CStr(varArrayValues(lng))) & """ onAction=""FileCustomOpen""/>" & vbLf
            Next lng
        Else 'xlFol
            GetRecentFiles False
            For lng = 0 To UBound(varArrayTypes)
                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
        End If
        xml = "<menu xmlns=""http://schemas.microsoft.com/office/2006/01/customui"" title=""ExcelFox.com Solutions"">" & vbLf & _
              xml & "</menu>"
        returnedVal = xml
        If IsArray(varArrayTypes) Then Erase varArrayTypes
        If IsArray(varArrayValues) Then Erase varArrayValues
        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'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
    
    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
    
    End Sub
    
    Function GiveFolder(strPath As String) As String
    
        Dim lng As Long
        
        lng = InStrRev(strPath, "\")
        GiveFolder = Left(strPath, lng)
        
    End Function
    
    Function GiveFile(strPath As String) As String
    
        Dim lng As Long
        
        lng = InStrRev(strPath, "\")
        GiveFile = ParseXML(Mid(strPath, lng + 1))
        
    End Function
    
    Function ParseXML(strText As String) As String
    
        ParseXML = Replace(strText, "&", "&amp;&amp;")
        ParseXML = Replace(ParseXML, "'", "&apos;")
        
    End Function
    PHP Code:
    <customUI onLoad="rxLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
          <
    ribbon startFromScratch="false">
                <
    officeMenu>
                      <
    dynamicMenu
                            id
    ="rxLst"
                            
    imageMso="AppointmentColorDialog"
                            
    getContent="rxDynMenuGetContent"
                            
    label="Recent Office Files"/>
                      <
    dynamicMenu
                            id
    ="rxFol"
                            
    imageMso="MenuPublish"
                            
    getContent="rxDynMenuGetContent"
                            
    label="Recent Office Folders"/>
                </
    officeMenu>
          </
    ribbon>
    </
    customUI
    Attached Files Attached Files

Similar Threads

  1. 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
  2. Moving Several Files To Several Folders
    By galang_ofel in forum Excel Help
    Replies: 3
    Last Post: 06-01-2013, 04:21 PM
  3. HOW TO Save Processed Files Into Different Folders
    By DARSHANKmandya in forum Outlook Help
    Replies: 6
    Last Post: 04-10-2013, 07:29 PM
  4. Replies: 1
    Last Post: 02-14-2013, 11:08 AM
  5. Looping through Each Files and Folders
    By Rajan_Verma in forum Rajan Verma's Corner
    Replies: 0
    Last Post: 04-18-2012, 12:12 AM

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
  •