J
Jules
In Word 2003 and Word 2007 I am only getting the LAST 4 subfolders to show plus loose documents in directory "My Documents". (1 level down from My Documents\) it falls over. It is working from the bottom folder up. The next folder in my Documents is "My Videos" and is blank and it stops at the "Set newPopup2 As Office.CommandBarPopup" etc. Would someone mind testing this please and see what they get please? And offer any ideas? Thank you.
Set newPopup2 = CreateNewPopup(newPopup.CommandBar, aLevTwoEntries(1, i), 1) '_ NO ERROR BUT IT FREEZES 2003/2007 and line is highlighted (SUBFOLDERS ONLY ADDS 4 from bottom up)
Option Explicit
'forces variable declaration
Const BaseFolderPath As String = "C:\Documents and Settings\USER\My Documents\" 'Insert user name or Path
Const ToolbarTarget As String = "Menu Bar"
Const ButtonName As String = "MenuTest"
Sub CreateFolderTreeMenu()
'Variable declaration
Dim aLevOneEntries() As String
Dim cb As Office.CommandBar
Dim ctlPopupMain As Office.CommandBarPopup
Dim i As Long
'Get the list of files and folders from the
'base folder specified in the Const BaseFolderPath
aLevOneEntries() = GetMenuEntries(BaseFolderPath)
'Make sure the changes will be stored in
'the Normal.dot template
CustomizationContext = NormalTemplate
'Specify in which toolbar the new menu
'will be created
Set cb = CommandBars(ToolbarTarget)
'Check to see if the button already exists
'and remove it if it does
If buttonExists(cb, ButtonName) = True Then
cb.Controls(ButtonName).Delete
End If
'Create the top-level dropdown
'at the end of the toolbar
Set ctlPopupMain = CreateNewPopup(cb, ButtonName, 0)
'Create entries for first-level files
For i = LBound(aLevOneEntries, 2) To UBound(aLevOneEntries, 2)
'Ignore any empty entries
If Len(aLevOneEntries(0, i)) <> 0 Then
CreateMenuButton ctlPopupMain.CommandBar, aLevOneEntries(0, i), BaseFolderPath
End If
Next i
'Create entries for first-level sub-folders
'Loop through folders in reverse order since
'each successive folder entry is inserted
'at the top of the list. Keeps them alphabetical
For i = UBound(aLevOneEntries, 2) To LBound(aLevOneEntries, 2) Step -1
If Len(aLevOneEntries(1, i)) <> 0 Then
'Variable declaration
Dim newPopup As Office.CommandBarPopup
'Create the popup entry
'position it at the top of the list (1)
Set newPopup = CreateNewPopup(ctlPopupMain.CommandBar, aLevOneEntries(1, i), 1)
'Process the lists for the second level popup
'Variable declaration
Dim aLevTwoEntries() As String
Dim LevTwoPath As String
Dim j As Long
LevTwoPath = BaseFolderPath & aLevOneEntries(1, i) & "\"
aLevTwoEntries() = GetMenuEntries(LevTwoPath)
'Create buttons for the second level files
For j = LBound(aLevTwoEntries, 2) To UBound(aLevTwoEntries, 2)
If Len(aLevTwoEntries(0, j)) <> 0 Then
CreateMenuButton newPopup.CommandBar, aLevTwoEntries(0, j), LevTwoPath
End If
Next j
'Now do any sub-folders at the second level
For j = LBound(aLevTwoEntries, 2) To UBound(aLevTwoEntries, 2)
If Len(aLevTwoEntries(1, j)) <> 0 Then
'Variable declaration
Dim newPopup2 As Office.CommandBarPopup
Set newPopup2 = CreateNewPopup(newPopup.CommandBar, aLevTwoEntries(1, i), 1) 'No error but it freezes 2007 (subfolders only adds 3)
'Get the thirdlevel entries
'Variable declaration
Dim aLevThreeEntries() As String
Dim k As Long
aLevThreeEntries() = GetMenuEntries(LevTwoPath & aLevTwoEntries(1, i) & "\")
'Only show files, for this level
For k = LBound(aLevThreeEntries, 2) To UBound(aLevThreeEntries, 2)
If Len(aLevThreeEntries(0, k)) <> 0 Then
CreateMenuButton newPopup2.CommandBar, aLevThreeEntries(0, k), LevTwoPath & aLevTwoEntries(1, j) & "\"
End If
Next k
End If
Next j
End If
Next i
End Sub
'Remove the entire menu, with all sub-entries
'by removing the top-level popup
Sub DeleteTree()
'Variable declaration
Dim cb As Office.CommandBar
CustomizationContext = NormalTemplate
Set cb = CommandBars(ToolbarTarget)
If buttonExists(cb, ButtonName) = True Then
cb.Controls(ButtonName).Delete
End If
End Sub
'Get all files and folders in the specified path
'and return them in an array
Function GetMenuEntries(path As String) As Variant
'Variable declaration
Dim folderContent As String
Dim filePath As String
Dim aEntries() As String
Dim iFileEntry As Long
Dim iDirEntry As Long
'Store the type (file or directory) and
'name in an array, to pass back
'The array has two dimensions
'All entries with 0 in the first dimension
'are file names; all entries with 1
'in the first dimension are folders
ReDim aEntries(1, 0)
'Start processing the folder tree in the base path...
folderContent = Dir(path, vbDirectory + vbNormal)
'Looping through each entry in the folder
'until no more are found
'Repeats a block of statements while a condition is True
'or until a condition becomes True.
Do While folderContent <> ""
filePath = path & folderContent
'Determine which kind of entry is being dealt with
'Executes one of several groups of statements
'depending on the value of an expression.
Select Case GetAttr(filePath)
Case vbArchive, vbNormal
'Only increment the second array dimension
'as necessary
If iFileEntry >= iDirEntry Then
ReDim Preserve aEntries(1, iFileEntry)
End If
'add file to the appropriate array dimension
aEntries(0, iFileEntry) = folderContent
'increment the counter for this type
iFileEntry = iFileEntry + 1
Case vbDirectory
'Don't pick up the folder itself,
'nor its "parent"
If folderContent <> "." And folderContent <> ".." Then
'Only increment the second array dimension
'as necessary
If iDirEntry >= iFileEntry Then
ReDim Preserve aEntries(1, iDirEntry)
End If
aEntries(1, iDirEntry) = folderContent
iDirEntry = iDirEntry + 1
End If
Case Else
End Select
'Go to the next entry
folderContent = Dir
Loop
GetMenuEntries = aEntries()
End Function
Function CreateNewPopup( _
cb As CommandBar, _
s As String, _
Pos As Long) As Office.CommandBarPopup
'Variable declaration
Dim ctl As Office.CommandBarPopup
'If 0 is passed in, then the entry should appear
'at the end of the list
If Pos = 0 Then
Set ctl = cb.Controls.Add(Type:=msoControlPopup)
Else
'Otherwise, place it at the top
Set ctl = cb.Controls.Add(Type:=msoControlPopup, Before:=Pos)
End If
'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.
With ctl
'The folder name is the caption
.Caption = s
.Enabled = True
.Visible = True
End With
Set CreateNewPopup = ctl
End Function
Function CreateMenuButton( _
cb As CommandBar, _
filename As String, _
path As String)
'Variable declaration
Dim ctl As Office.CommandBarButton
Dim filetype As String
'Determine what kind of file by the extension
filetype = GetFileType(path & filename)
'Don't include unwanted file types
'to deal with
If filetype = "unknown" Then Exit Function
'Create the new button
Set ctl = cb.Controls.Add(Type:=msoControlButton)
'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.
With ctl
.Caption = filename
.Enabled = True
.Visible = True
'The macro to run when the button is clicked
'in this case, all buttons run the same macro
.OnAction = "ProcessFile"
'Store the path in the Tag property
'so that OnAction macro can access it
.Tag = path
'Only Word 2002/2003 support adding a
'picture from a file
If Application.Version >= 10 Then
AddButtonPicture ctl, filetype
End If
End With
End Function
Function GetFileType(s As String) As String
'Variable declaration
Dim ext As String
Dim loc As Long
'The file extension follows the last .
'in the filename. Determine
'at which position this is
loc = InStr(s, ".")
'Loop until no more . are found
'What's left in the ext string is the file extension
'Repeats a block of statements while a condition is True
'or until a condition becomes True.
Do
ext = Mid(s, loc + 1)
loc = InStr(ext, ".")
s = ext
Loop Until loc = 0
'Set the file type, based on the extension
Select Case ext
Case "doc", "dot", "dotx", "dotm", "docm", "docx", "htm", "html", _
"rtf", "txt", "csv"
GetFileType = "Word"
Case "xls", "tlsx", "xlsm", "xlsb", "xltx"
GetFileType = "Excel"
Case "ppt", "potx", "pptm", "pptx", "potm"
GetFileType = "Powerpoint"
Case "bmp", "gif", "jpg", "tif"
GetFileType = "Graphic"
Case Else
GetFileType = "unknown"
End Select
End Function
Function buttonExists( _
cb As Office.CommandBar, _
s As String) As Boolean
Dim c As Office.CommandBarControl
buttonExists = False
'Determine whether the button already
'exists in the specififed toolbar,
'based on its caption
For Each c In cb.Controls
If c.Caption = s Then
buttonExists = True
Exit For
End If
Next c
End Function
'Common macro executed by all buttons
'for valid file types
Sub ProcessFile()
Dim ctl As Office.CommandBarButton
Dim filetype As String
Dim filename As String
'The ActionControl property gives us
'the button that was clicked
Set ctl = Application.CommandBars.ActionControl
'Determine the file type, based on the extension
filetype = GetFileType(ctl.Caption)
filename = ctl.Tag & ctl.Caption
'Depending on the file type, perform an action
Select Case filetype
Case "Word"
'Word and text files are opened
Documents.Open ctl.Tag & ctl.Caption
Case "Excel"
'Excel files are inserted as Excel
'spreadsheet objects
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Excel.Sheet.8", _
filename:=filename, _
Range:=Selection.Range
Case "Powerpoint"
'Powerpoint files are inserted as
'presentation objects
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="PowerPoint.Show.8", _
filename:=filename, _
Range:=Selection.Range
Case "Graphic"
'Graphics are inserted as embedded pictures
ActiveDocument.InlineShapes.AddPicture _
filename:=filename, _
Range:=Selection.Range
Case "unknown"
Case Else
End Select
End Sub
Set newPopup2 = CreateNewPopup(newPopup.CommandBar, aLevTwoEntries(1, i), 1) '_ NO ERROR BUT IT FREEZES 2003/2007 and line is highlighted (SUBFOLDERS ONLY ADDS 4 from bottom up)
Option Explicit
'forces variable declaration
Const BaseFolderPath As String = "C:\Documents and Settings\USER\My Documents\" 'Insert user name or Path
Const ToolbarTarget As String = "Menu Bar"
Const ButtonName As String = "MenuTest"
Sub CreateFolderTreeMenu()
'Variable declaration
Dim aLevOneEntries() As String
Dim cb As Office.CommandBar
Dim ctlPopupMain As Office.CommandBarPopup
Dim i As Long
'Get the list of files and folders from the
'base folder specified in the Const BaseFolderPath
aLevOneEntries() = GetMenuEntries(BaseFolderPath)
'Make sure the changes will be stored in
'the Normal.dot template
CustomizationContext = NormalTemplate
'Specify in which toolbar the new menu
'will be created
Set cb = CommandBars(ToolbarTarget)
'Check to see if the button already exists
'and remove it if it does
If buttonExists(cb, ButtonName) = True Then
cb.Controls(ButtonName).Delete
End If
'Create the top-level dropdown
'at the end of the toolbar
Set ctlPopupMain = CreateNewPopup(cb, ButtonName, 0)
'Create entries for first-level files
For i = LBound(aLevOneEntries, 2) To UBound(aLevOneEntries, 2)
'Ignore any empty entries
If Len(aLevOneEntries(0, i)) <> 0 Then
CreateMenuButton ctlPopupMain.CommandBar, aLevOneEntries(0, i), BaseFolderPath
End If
Next i
'Create entries for first-level sub-folders
'Loop through folders in reverse order since
'each successive folder entry is inserted
'at the top of the list. Keeps them alphabetical
For i = UBound(aLevOneEntries, 2) To LBound(aLevOneEntries, 2) Step -1
If Len(aLevOneEntries(1, i)) <> 0 Then
'Variable declaration
Dim newPopup As Office.CommandBarPopup
'Create the popup entry
'position it at the top of the list (1)
Set newPopup = CreateNewPopup(ctlPopupMain.CommandBar, aLevOneEntries(1, i), 1)
'Process the lists for the second level popup
'Variable declaration
Dim aLevTwoEntries() As String
Dim LevTwoPath As String
Dim j As Long
LevTwoPath = BaseFolderPath & aLevOneEntries(1, i) & "\"
aLevTwoEntries() = GetMenuEntries(LevTwoPath)
'Create buttons for the second level files
For j = LBound(aLevTwoEntries, 2) To UBound(aLevTwoEntries, 2)
If Len(aLevTwoEntries(0, j)) <> 0 Then
CreateMenuButton newPopup.CommandBar, aLevTwoEntries(0, j), LevTwoPath
End If
Next j
'Now do any sub-folders at the second level
For j = LBound(aLevTwoEntries, 2) To UBound(aLevTwoEntries, 2)
If Len(aLevTwoEntries(1, j)) <> 0 Then
'Variable declaration
Dim newPopup2 As Office.CommandBarPopup
Set newPopup2 = CreateNewPopup(newPopup.CommandBar, aLevTwoEntries(1, i), 1) 'No error but it freezes 2007 (subfolders only adds 3)
'Get the thirdlevel entries
'Variable declaration
Dim aLevThreeEntries() As String
Dim k As Long
aLevThreeEntries() = GetMenuEntries(LevTwoPath & aLevTwoEntries(1, i) & "\")
'Only show files, for this level
For k = LBound(aLevThreeEntries, 2) To UBound(aLevThreeEntries, 2)
If Len(aLevThreeEntries(0, k)) <> 0 Then
CreateMenuButton newPopup2.CommandBar, aLevThreeEntries(0, k), LevTwoPath & aLevTwoEntries(1, j) & "\"
End If
Next k
End If
Next j
End If
Next i
End Sub
'Remove the entire menu, with all sub-entries
'by removing the top-level popup
Sub DeleteTree()
'Variable declaration
Dim cb As Office.CommandBar
CustomizationContext = NormalTemplate
Set cb = CommandBars(ToolbarTarget)
If buttonExists(cb, ButtonName) = True Then
cb.Controls(ButtonName).Delete
End If
End Sub
'Get all files and folders in the specified path
'and return them in an array
Function GetMenuEntries(path As String) As Variant
'Variable declaration
Dim folderContent As String
Dim filePath As String
Dim aEntries() As String
Dim iFileEntry As Long
Dim iDirEntry As Long
'Store the type (file or directory) and
'name in an array, to pass back
'The array has two dimensions
'All entries with 0 in the first dimension
'are file names; all entries with 1
'in the first dimension are folders
ReDim aEntries(1, 0)
'Start processing the folder tree in the base path...
folderContent = Dir(path, vbDirectory + vbNormal)
'Looping through each entry in the folder
'until no more are found
'Repeats a block of statements while a condition is True
'or until a condition becomes True.
Do While folderContent <> ""
filePath = path & folderContent
'Determine which kind of entry is being dealt with
'Executes one of several groups of statements
'depending on the value of an expression.
Select Case GetAttr(filePath)
Case vbArchive, vbNormal
'Only increment the second array dimension
'as necessary
If iFileEntry >= iDirEntry Then
ReDim Preserve aEntries(1, iFileEntry)
End If
'add file to the appropriate array dimension
aEntries(0, iFileEntry) = folderContent
'increment the counter for this type
iFileEntry = iFileEntry + 1
Case vbDirectory
'Don't pick up the folder itself,
'nor its "parent"
If folderContent <> "." And folderContent <> ".." Then
'Only increment the second array dimension
'as necessary
If iDirEntry >= iFileEntry Then
ReDim Preserve aEntries(1, iDirEntry)
End If
aEntries(1, iDirEntry) = folderContent
iDirEntry = iDirEntry + 1
End If
Case Else
End Select
'Go to the next entry
folderContent = Dir
Loop
GetMenuEntries = aEntries()
End Function
Function CreateNewPopup( _
cb As CommandBar, _
s As String, _
Pos As Long) As Office.CommandBarPopup
'Variable declaration
Dim ctl As Office.CommandBarPopup
'If 0 is passed in, then the entry should appear
'at the end of the list
If Pos = 0 Then
Set ctl = cb.Controls.Add(Type:=msoControlPopup)
Else
'Otherwise, place it at the top
Set ctl = cb.Controls.Add(Type:=msoControlPopup, Before:=Pos)
End If
'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.
With ctl
'The folder name is the caption
.Caption = s
.Enabled = True
.Visible = True
End With
Set CreateNewPopup = ctl
End Function
Function CreateMenuButton( _
cb As CommandBar, _
filename As String, _
path As String)
'Variable declaration
Dim ctl As Office.CommandBarButton
Dim filetype As String
'Determine what kind of file by the extension
filetype = GetFileType(path & filename)
'Don't include unwanted file types
'to deal with
If filetype = "unknown" Then Exit Function
'Create the new button
Set ctl = cb.Controls.Add(Type:=msoControlButton)
'"With" allows multiple properties of an object to be set
'by treating the words on the With line as a prefix for the
'lines that start with a .(period) that follow. The With
'must be ended.
With ctl
.Caption = filename
.Enabled = True
.Visible = True
'The macro to run when the button is clicked
'in this case, all buttons run the same macro
.OnAction = "ProcessFile"
'Store the path in the Tag property
'so that OnAction macro can access it
.Tag = path
'Only Word 2002/2003 support adding a
'picture from a file
If Application.Version >= 10 Then
AddButtonPicture ctl, filetype
End If
End With
End Function
Function GetFileType(s As String) As String
'Variable declaration
Dim ext As String
Dim loc As Long
'The file extension follows the last .
'in the filename. Determine
'at which position this is
loc = InStr(s, ".")
'Loop until no more . are found
'What's left in the ext string is the file extension
'Repeats a block of statements while a condition is True
'or until a condition becomes True.
Do
ext = Mid(s, loc + 1)
loc = InStr(ext, ".")
s = ext
Loop Until loc = 0
'Set the file type, based on the extension
Select Case ext
Case "doc", "dot", "dotx", "dotm", "docm", "docx", "htm", "html", _
"rtf", "txt", "csv"
GetFileType = "Word"
Case "xls", "tlsx", "xlsm", "xlsb", "xltx"
GetFileType = "Excel"
Case "ppt", "potx", "pptm", "pptx", "potm"
GetFileType = "Powerpoint"
Case "bmp", "gif", "jpg", "tif"
GetFileType = "Graphic"
Case Else
GetFileType = "unknown"
End Select
End Function
Function buttonExists( _
cb As Office.CommandBar, _
s As String) As Boolean
Dim c As Office.CommandBarControl
buttonExists = False
'Determine whether the button already
'exists in the specififed toolbar,
'based on its caption
For Each c In cb.Controls
If c.Caption = s Then
buttonExists = True
Exit For
End If
Next c
End Function
'Common macro executed by all buttons
'for valid file types
Sub ProcessFile()
Dim ctl As Office.CommandBarButton
Dim filetype As String
Dim filename As String
'The ActionControl property gives us
'the button that was clicked
Set ctl = Application.CommandBars.ActionControl
'Determine the file type, based on the extension
filetype = GetFileType(ctl.Caption)
filename = ctl.Tag & ctl.Caption
'Depending on the file type, perform an action
Select Case filetype
Case "Word"
'Word and text files are opened
Documents.Open ctl.Tag & ctl.Caption
Case "Excel"
'Excel files are inserted as Excel
'spreadsheet objects
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="Excel.Sheet.8", _
filename:=filename, _
Range:=Selection.Range
Case "Powerpoint"
'Powerpoint files are inserted as
'presentation objects
ActiveDocument.InlineShapes.AddOLEObject _
ClassType:="PowerPoint.Show.8", _
filename:=filename, _
Range:=Selection.Range
Case "Graphic"
'Graphics are inserted as embedded pictures
ActiveDocument.InlineShapes.AddPicture _
filename:=filename, _
Range:=Selection.Range
Case "unknown"
Case Else
End Select
End Sub