PDA

View Full Version : Excel 2007 To 2010 Ribbon Dynamic Menu Content Using VBA To Display MRU Most Recent


Excel Fox
11-23-2013, 08:20 PM
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/excel-2007-officemenu-addin-for-recent-files-and-folders-using-dynamicmenu-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/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=SIDLFRkUEIo&lc=UgzTF5vvB67Zbfs9qvx4AaABAg (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=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=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=f7xZivqLZxc&lc=UgzMCQUIQgrbec400jl4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (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=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw (https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg.9irLgSdeU3r9itU7zdnW Hw)
https://www.youtube.com/watch?v=tPRv-ATUBe4&lc=UgzFkoI0n_BxwnwVMcZ4AaABAg (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=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
Excel Fox
11-23-2013, 08:41 PM
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