nooch
09-17-2008, 01:39 AM
Hi,
I'm trying to create a dynamic menu to be included into our template, so that when the user opens word a menu is created based on a file structure of document templates (as well as other office documents).
So far the operation takes 7 seconds to complete.
The plan was to run the CreateMenu sub everytime word was opened, which would remove the old menu, and create a new menu based on the folder/file structure.
Now obviously if this is taking 7 seconds (and that's on a half decent PC) i can't implement it, so Plan B was to get a technician to rebuild the menu every time a document was added (or every so often) and deploy that 'static' menu with the template. So basically it would be a static menu to the users, but with the ability to be created dynamically.
I hope you're still with me so far because i'm banging my head on my desk over this one (me)-->:banghead: <--(desk)
So my question is this.
Can anyone recommend a way to improve the speed of this operation, so i can implement the menu dynamically to the user?
-or-
Does anyone know how I can allow the technician to create the menu dynamically, and then deploy it as a static menu? (So far i can create the menu, but not sure how to save it into the template, so that when it loads up it's already built).
I will be eternally thankful to anyone who can point me in the right direction with this one. Hopefully the code will also be of some use to someone else
Cheers,
Danny
Code:
Const strFolder = "Y:\smdd\templates"
Private oFSO As New FileSystemObject
Private oFolder As Folder
Dim f As File
Dim RootBar As CommandBar
Public Function RootMenuExists(strMenuName As String) As Boolean
Dim cbc As CommandBarControl
RootMenuExists = False
For Each cbc In CommandBars("Menu Bar").Controls
If cbc.Caption = strMenuName Then RootMenuExists = True
Next
End Function
Sub CreateMenu()
Debug.Print Now
Set oFSO = New FileSystemObject
Dim strMenuName As String
strMenuName = "&Simpson Millar LLP"
If RootMenuExists(strMenuName) Then
CommandBars("Menu Bar").Controls(strMenuName).Delete
End If
Dim tmpCMDRoot As CommandBarControl
Set tmpCMDRoot = CommandBars("Menu Bar").Controls.Add(Type:=msoControlPopup)
tmpCMDRoot.Caption = strMenuName
Set RootBar = CommandBars("Menu Bar").Controls(strMenuName).CommandBar
getFolders strFolder, Nothing
Debug.Print Now
End Sub
Private Sub getFolders(strRoot As String, Optional ctrlCommandBar As CommandBarControl = Nothing)
Set oFolder = oFSO.GetFolder(strRoot)
For Each f In oFolder.Files
If InStr(f.Path, "~$") > 0 Or InStr(f.Path, "Thumbs.db") > 0 Then GoTo continue
'Ignore this Select Case, it's for a future version
Select Case UCase(Right(f.Path, 4))
Case ".DOC"
'Word Doc
Case ".DOT"
'Word Template
Case ".PPT"
'PowerPoint
Case ".XLS"
'Excel
Case ".MDB"
'Access
End Select
If ctrlCommandBar Is Nothing Then
CreateButtonIn RootBar.NameLocal, RemoveExtension(f.Name), f.Path
Else
CreateButtonIn ctrlCommandBar.CommandBar.Name, RemoveExtension(f.Name), f.Path
End If
continue:
'continue for
Next
For Each sf In oFolder.SubFolders
If ctrlCommandBar Is Nothing Then
getFolders sf.Path, CreateFolderIn(RootBar.NameLocal, sf.Name)
Else
getFolders sf.Path, CreateFolderIn(ctrlCommandBar.CommandBar.Name, sf.Name)
End If
Next
End Sub
Private Function RemoveExtension(strPath As String) As String
RemoveExtension = Left(strPath, InStrRev(strPath, ".") - 1)
End Function
Public Function CreateFolderIn(Parent As String, strCaption As String) As CommandBarPopup
Dim ctl As CommandBarPopup
Set ctl = CommandBars(Parent).Controls.Add(Type:=msoControlPopup)
If Mid(strCaption, 2, 1) = "_" Then
ctl.Caption = Right(strCaption, Len(strCaption) - 2)
Else
ctl.Caption = strCaption
End If
If LCase(Left(strCaption, 2)) = "a_" Then ctl.BeginGroup = True
Set CreateFolderIn = ctl
End Function
Public Function CreateButtonIn(Parent As String, strCaption As String, Optional strDocumentPath As String = "") As CommandBarButton
Dim ctl As CommandBarButton
Set ctl = CommandBars(Parent).Controls.Add(Type:=msoControlButton)
ctl.Caption = strCaption
ctl.OnAction = "OpenDocument"
'ctl.Parameter = strDocumentPath
'ctl.HyperlinkType = msoCommandBarButtonHyperlinkOpen
ctl.TooltipText = strDocumentPath
Set CreateButtonIn = ctl
End Function
Public Function OpenDocument()
Documents.Add template:=CommandBars.ActionControl.TooltipText
End Function
I'm trying to create a dynamic menu to be included into our template, so that when the user opens word a menu is created based on a file structure of document templates (as well as other office documents).
So far the operation takes 7 seconds to complete.
The plan was to run the CreateMenu sub everytime word was opened, which would remove the old menu, and create a new menu based on the folder/file structure.
Now obviously if this is taking 7 seconds (and that's on a half decent PC) i can't implement it, so Plan B was to get a technician to rebuild the menu every time a document was added (or every so often) and deploy that 'static' menu with the template. So basically it would be a static menu to the users, but with the ability to be created dynamically.
I hope you're still with me so far because i'm banging my head on my desk over this one (me)-->:banghead: <--(desk)
So my question is this.
Can anyone recommend a way to improve the speed of this operation, so i can implement the menu dynamically to the user?
-or-
Does anyone know how I can allow the technician to create the menu dynamically, and then deploy it as a static menu? (So far i can create the menu, but not sure how to save it into the template, so that when it loads up it's already built).
I will be eternally thankful to anyone who can point me in the right direction with this one. Hopefully the code will also be of some use to someone else
Cheers,
Danny
Code:
Const strFolder = "Y:\smdd\templates"
Private oFSO As New FileSystemObject
Private oFolder As Folder
Dim f As File
Dim RootBar As CommandBar
Public Function RootMenuExists(strMenuName As String) As Boolean
Dim cbc As CommandBarControl
RootMenuExists = False
For Each cbc In CommandBars("Menu Bar").Controls
If cbc.Caption = strMenuName Then RootMenuExists = True
Next
End Function
Sub CreateMenu()
Debug.Print Now
Set oFSO = New FileSystemObject
Dim strMenuName As String
strMenuName = "&Simpson Millar LLP"
If RootMenuExists(strMenuName) Then
CommandBars("Menu Bar").Controls(strMenuName).Delete
End If
Dim tmpCMDRoot As CommandBarControl
Set tmpCMDRoot = CommandBars("Menu Bar").Controls.Add(Type:=msoControlPopup)
tmpCMDRoot.Caption = strMenuName
Set RootBar = CommandBars("Menu Bar").Controls(strMenuName).CommandBar
getFolders strFolder, Nothing
Debug.Print Now
End Sub
Private Sub getFolders(strRoot As String, Optional ctrlCommandBar As CommandBarControl = Nothing)
Set oFolder = oFSO.GetFolder(strRoot)
For Each f In oFolder.Files
If InStr(f.Path, "~$") > 0 Or InStr(f.Path, "Thumbs.db") > 0 Then GoTo continue
'Ignore this Select Case, it's for a future version
Select Case UCase(Right(f.Path, 4))
Case ".DOC"
'Word Doc
Case ".DOT"
'Word Template
Case ".PPT"
'PowerPoint
Case ".XLS"
'Excel
Case ".MDB"
'Access
End Select
If ctrlCommandBar Is Nothing Then
CreateButtonIn RootBar.NameLocal, RemoveExtension(f.Name), f.Path
Else
CreateButtonIn ctrlCommandBar.CommandBar.Name, RemoveExtension(f.Name), f.Path
End If
continue:
'continue for
Next
For Each sf In oFolder.SubFolders
If ctrlCommandBar Is Nothing Then
getFolders sf.Path, CreateFolderIn(RootBar.NameLocal, sf.Name)
Else
getFolders sf.Path, CreateFolderIn(ctrlCommandBar.CommandBar.Name, sf.Name)
End If
Next
End Sub
Private Function RemoveExtension(strPath As String) As String
RemoveExtension = Left(strPath, InStrRev(strPath, ".") - 1)
End Function
Public Function CreateFolderIn(Parent As String, strCaption As String) As CommandBarPopup
Dim ctl As CommandBarPopup
Set ctl = CommandBars(Parent).Controls.Add(Type:=msoControlPopup)
If Mid(strCaption, 2, 1) = "_" Then
ctl.Caption = Right(strCaption, Len(strCaption) - 2)
Else
ctl.Caption = strCaption
End If
If LCase(Left(strCaption, 2)) = "a_" Then ctl.BeginGroup = True
Set CreateFolderIn = ctl
End Function
Public Function CreateButtonIn(Parent As String, strCaption As String, Optional strDocumentPath As String = "") As CommandBarButton
Dim ctl As CommandBarButton
Set ctl = CommandBars(Parent).Controls.Add(Type:=msoControlButton)
ctl.Caption = strCaption
ctl.OnAction = "OpenDocument"
'ctl.Parameter = strDocumentPath
'ctl.HyperlinkType = msoCommandBarButtonHyperlinkOpen
ctl.TooltipText = strDocumentPath
Set CreateButtonIn = ctl
End Function
Public Function OpenDocument()
Documents.Add template:=CommandBars.ActionControl.TooltipText
End Function