S M C
05-29-2012, 10:32 PM
243
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, "&", "&&")
ParseXML = Replace(ParseXML, "'", "'")
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>
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, "&", "&&")
ParseXML = Replace(ParseXML, "'", "'")
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>