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
Reply With Quote
Bookmarks