Excel 2007 OfficeMenu Addin For Recent Files and Folders Using DynamicMenu

[S M C]

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.

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

<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>