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

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, "&", "&&") XMLParse = Replace(XMLParse, "'", "'") 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