How do you find which template a macro run by a command bar item is located?

[johndavidson]

I have some code that lists all the macro names associated with all the command bar items. In my system, there are multiple templates, so the code can still leave me unsure of which template the macro is in. How can I discover the template in which the macro is located. The code (before formatting the output) looks like this. I want to add the template name to the output associated with each command bar item.


Dim cmd As CommandBar
Dim ctrl As CommandBarControl
Dim itm As CommandBarControl
Dim itm2 As CommandBarControl
Dim menuName As String
Dim menuName2 As String


For Each cmd In Application.CommandBars
If cmd.BuiltIn = False Then
Selection.TypeText (vbCrLf & vbCrLf & "Command Bar : " & cmd.Name & " Visible [" & cmd.Visible & "]" & vbCrLf & vbCrLf)

For Each ctrl In cmd.Controls
If ctrl.Type = 1 Then
Selection.TypeText (ChrW(9) & ctrl.Caption & ChrW(9) & ">" & ChrW(9) & ctrl.OnAction & vbCrLf)
Else
menuName = ctrl.Caption
Selection.TypeText vbCrLf
For Each itm In cmd.Controls(menuName).Controls
If itm.Type = 1 Then
Selection.TypeText (ChrW(9) & menuName & " | " & itm.Caption & ChrW(9) & ">" & ChrW(9) & itm.OnAction & vbCrLf)
Else
menuName2 = itm.Caption
Selection.TypeText vbCrLf
For Each itm2 In cmd.Controls(menuName).Controls(menuName2).Controls
Selection.TypeText (ChrW(9) & menuName & " | " & menuName2 & " | " & itm2.Caption & ChrW(9) & ">" & ChrW(9) & itm2.OnAction & vbCrLf)
Next
End If
Next
End If
Next
End If
Next

In case it is of use to anyone, the code in its present form is in the attached Word doc.

Thanks

John Davidson

[johndavidson]

I did some tinkering and came up with the solution. Need to extract parent template name from ctrl.Parent.Context. Full code is attached in case anyone is interested:


For Each cmd In Application.CommandBars
If cmd.BuiltIn = False Then
Selection.TypeText (vbCrLf & vbCrLf & "Command Bar : " & cmd.Name & " Visible [" & cmd.Visible & "]" & vbCrLf & vbCrLf)

For Each ctrl In cmd.Controls
If ctrl.Type = 1 Then
Selection.TypeText (ChrW(9) & ctrl.Caption & ChrW(9) & ">" & ChrW(9) & ctrl.OnAction & " (" & _
Mid(ctrl.Parent.Context, InStrRev(ctrl.Parent.Context, "\") + 1, InStrRev(ctrl.Parent.Context, ".") - InStrRev(ctrl.Parent.Context, "\") - 1) & ")" & vbCrLf)
Else
menuName = ctrl.Caption
Selection.TypeText vbCrLf
For Each itm In cmd.Controls(menuName).Controls
If itm.Type = 1 Then
Selection.TypeText (ChrW(9) & menuName & " | " & itm.Caption & ChrW(9) & ">" & ChrW(9) & itm.OnAction & " (" & _
Mid(ctrl.Parent.Context, InStrRev(ctrl.Parent.Context, "\") + 1, InStrRev(ctrl.Parent.Context, ".") - InStrRev(ctrl.Parent.Context, "\") - 1) & ")" & vbCrLf)
Else
menuName2 = itm.Caption
Selection.TypeText vbCrLf
For Each itm2 In cmd.Controls(menuName).Controls(menuName2).Controls
Selection.TypeText (ChrW(9) & menuName & " | " & menuName2 & " | " & itm2.Caption & ChrW(9) & ">" & ChrW(9) & itm2.OnAction & " (" & _
Mid(ctrl.Parent.Context, InStrRev(ctrl.Parent.Context, "\") + 1, InStrRev(ctrl.Parent.Context, ".") - InStrRev(ctrl.Parent.Context, "\") - 1) & ")" & vbCrLf)
Next
End If
Next
End If
Next
End If
Next

[gmaxey]

You can streamline your code a bit like this:

Sub ScratchMacro()

Dim cmd, ctrl, menuname, menuname2
Dim itm, itm2
Dim strFile As String
For Each cmd In Application.CommandBars
strFile = vbNullString
If cmd.BuiltIn = False Then
Selection.TypeText vbCrLf & vbCrLf & "Command Bar : " & cmd.Name & _
" Visible [" & cmd.Visible & "]" & vbCrLf & vbCrLf
For Each ctrl In cmd.Controls
If strFile = vbNullString Then
strFile = CreateObject("scripting.filesystemobject").GetBaseName(ctrl.Parent.Context)
End If
If ctrl.Type = 1 Then
Selection.TypeText vbTab & ctrl.Caption & vbTab & ">" & vbTab & ctrl.OnAction & " (" & strFile & ")" & vbCrLf
Else
menuname = ctrl.Caption
Selection.TypeText vbCrLf
For Each itm In cmd.Controls(menuname).Controls
If itm.Type = 1 Then
Selection.TypeText vbTab & menuname & " | " & itm.Caption & vbTab & ">" & vbTab & _
itm.OnAction & " (" & strFile & ")" & vbCrLf
Else
menuname2 = itm.Caption
Selection.TypeText vbCrLf
For Each itm2 In cmd.Controls(menuname).Controls(menuname2).Controls
Selection.TypeText vbTab & menuname & " | " & menuname2 & " | " & _
itm2.Caption & vbTab & ">" & vbTab & itm2.OnAction & " (" & strFile & ")" & vbCrLf
Next
End If
Next
End If
Next
End If
Next
lbl_Exit:
Exit Sub
End Sub

[johndavidson]

Mmmm ... thanks Greg, that looks a whole lot tidier! Good to have a professional on the job!

Maxeyfied version attached.

John

[johndavidson]

Greg - just noticed that there is a bug in my logic, copied through into yours. One of my templates (MenusToolbar.dot) contains a collection of additions to the main menu bar, without any code, just the menu additions. The macros called from menu items in those menus show the template as MenusToolbar.dot, rather than the actual template in which the macro is located. Seems like we need to dig down to the bottom to be sure of getting the actual template in which the macro is stored. How to do that?

John

[gmaxey]

John,

I edited to remove the "A basic macro coded by Greg Maxey" in my last post. That is part of an autotext I use when starting a macro and got left in my mistake.
Not sure how to do that if it can be done. Can you share the template and I will try to look at it later

[johndavidson]

Greg - Actually, it's not just the Menus Toolbar. It's ALL the toolbars. For any toolbar/menu item, the context that gets shown, using either your method or mine, is the template that contains the toolbar, not the template containing the macro. So we are still short on how to discover the template that contains the macro that is run from a toolbar item.

Any code that can locate which template is invoked by a menu item would need to be done at the item level, where I am presently doing it (but getting the wrong answer).

I have tinkered with the various pop-up options, even tried ctrl.Parent.Controls.Parent.Context which still gives the name of the template containing the toolbar.

Since we do have the code module name, one way to handle the need to know the parent template name may be identify the template containing that particular code module. Is there a way to do that?

Alternatively, one could add some code that lists the modules in all templates that have toolbars. Then the user can simply look up which template(s) have that module name. There may be some code around which does that for Word templates.

[gmaxey]

John

Here I some code I had squirreled away for listing macros in a document. You may be able to adapt it to suit your needs:


Option Explicit
'Procedures require a reference set to Microsoft Visual Basice for Application Extensibility
Sub MacroList()
Dim oRng As Word.Range
Dim oProject As VBIDE.VBProject
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
Set oRng = ActiveDocument.Range
oRng.InsertAfter "The project Name is: " & oProject.Name & "." & vbCr & vbCr
With oProject
For i = 1 To .VBComponents.Count
oRng.InsertAfter vbTab & "Component " & i & " " & Chr(150) & " Name: " _
& .VBComponents(i).Name & " Type: " & ComponentTypeToString(.VBComponents(i).Type) & vbCr
lngLineCount = .VBComponents(i).CodeModule.CountOfLines
If lngLineCount > 3 Then
strName = ""
lngLineNumber = 1
j = 1
Do While strName = ""
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
lngLineNumber = lngLineNumber + 1
Loop
oRng.InsertAfter vbTab & vbTab & "The procedure(s) in this component are:" & vbCr _
& vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
For lngLineNumber = lngLineNumber To lngLineCount
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If
Next
Else
oRng.InsertAfter vbTab & vbTab & "There are no procedures in this component." & vbCr
End If
oRng.InsertAfter vbCr
Next i
End With
Set oRng = Nothing
Set oProject = Nothing
End Sub
Sub ProjectModuleExport()
Dim oProject As VBProject
Dim strProject As String
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
With oProject
For i = 1 To .VBComponents.Count
MsgBox .VBComponents(i).Name
Select Case .VBComponents(i).Type
Case vbext_ct_StdModule, vbext_ct_ClassModule, vbext_ct_MSForm
.VBComponents(i).Export ("C:\" & .Name & "_" & .VBComponents(i).Name & ".bas")
Case Else
End Select
Next
End With
End Sub
Sub CopyMacroCodeToDoc()
Dim oRng As Word.Range
Dim oProject As VBProject
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
Set oRng = ActiveDocument.Range
oRng.InsertAfter oProject.Name & "." & vbCr & vbCr
With oProject
For i = 1 To .VBComponents.Count
oRng.InsertAfter .VBComponents(i).CodeModule.Lines(1, .VBComponents(i).CodeModule.CountOfLines)
Next i
End With
Set oRng = Nothing
Set oProject = Nothing
End Sub
Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String
Select Case ComponentType
Case vbext_ct_ActiveXDesigner
ComponentTypeToString = "ActiveX Designer"
Case vbext_ct_ClassModule
ComponentTypeToString = "Class Module"
Case vbext_ct_Document
ComponentTypeToString = "Document Module"
Case vbext_ct_MSForm
ComponentTypeToString = "UserForm"
Case vbext_ct_StdModule
ComponentTypeToString = "Code Module"
Case Else
ComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
End Select
End Function

[johndavidson]

Greg - That's a useful bit of code and it will do the trick - but there's a bug in it! I have a number of templates with Class Modules and on some types of module, the program loops forever on this bit of code (lngLineNumber just goes on getting bigger and bigger):


If lngLineCount > 3 Then
strName = ""
lngLineNumber = 1
j = 1
Do While strName = ""
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
lngLineNumber = lngLineNumber + 1
Loop
oRng.InsertAfter vbTab & vbTab & "The procedure(s) in this component are:" & vbCr _
& vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
For lngLineNumber = lngLineNumber To lngLineCount
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If
Next

I'm attaching a template (it italicizes words, and corrects italicization of surrounding punctuation, individually, with a global option) that causes the above code to loop forever. I tried another template with class modules, which generated the same error, so it is probably generic, rather than specific to a particular template.

Over to you

John

[johndavidson]

Greg - I now have the listing of the project and Code Module part of your code adapted for my purposes. Looks good. But your original code looks useful, in case you care to fix the Class Module bug. Looks like something simple. I'll upload my completed code later, after a little more testing.

John

[johndavidson]

Greg - And ... My code simply opens and closes all the templates in Word's startup folder in order to read the project names. I thought it would be better to use the Templates collection, but unless a template happens to be open, I get the message "Cant perform operation since project is protected VBA Word Templates". These templates have no protection (I've double checked). The code it doesn't like is


With oProject For i = 1 To .VBComponents.Count


I read somewhere that .VBComponents does like the use of "With", so I redid it as:


For i = 1 To oProject.VBComponents.Count
oRng.InsertAfter vbTab & oProject.VBComponents(i).Name & ".dot" & vbTab & ComponentTypeToString(oProject.VBComponents(i).Type) & vbCrLf
Next i


... but it made no difference. The full code snippet is:

Sub Test()
Dim oRng As Word.Range
Dim oProject As VBIDE.VBProject ' Requires reference to MicroSoft Visual Basic for Applications Extensibility 5.3
Dim i As Long
Dim vFile
Dim sTemp As String, WordStartUpPath As String


On Error GoTo 0
WordStartUpPath = Options.DefaultFilePath(wdStartupPath)


Documents.Add DocumentType:=wdNewBlankDocument

Set oRng = ActiveDocument.Range
oRng.InsertAfter vbCrLf & vbCrLf & "User Template Code Module List"

For Each vFile In Templates
Set oProject = vFile.VBProject
oRng.InsertAfter vbCrLf & vbCrLf & oProject.Name & vbCrLf
With oProject
For i = 1 To .VBComponents.Count
oRng.InsertAfter vbTab & .VBComponents(i).Name & ".dot" & vbTab & ComponentTypeToString(.VBComponents(i).Type) & vbCrLf
Next i
End With
Set oProject = Nothing
Next
End Sub


Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String
' Code by Greg Maxey


Select Case ComponentType
Case vbext_ct_ActiveXDesigner
ComponentTypeToString = "ActiveX Designer"
Case vbext_ct_ClassModule
ComponentTypeToString = "Class Module"
Case vbext_ct_Document
ComponentTypeToString = "Document Module"
Case vbext_ct_MSForm
ComponentTypeToString = "UserForm"
Case vbext_ct_StdModule
ComponentTypeToString = "Code Module"
Case Else
ComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
End Select
End Function

Any ideas?

Thanks

John

[gmaxey]

John,

Yes the problem was the code was looking for "procedures" only and not Property Gets, Lets or Sets. That is why is crashed and burned in the class modules. To complicate things your Class StackItem didn't have any of them. Here is modified version:


Option Explicit
'Procedures require a reference set to Microsoft Visual Basice for Application Extensibility
Sub MacroList()
Dim oRng As Word.Range
Dim oProject As VBIDE.VBProject
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
Set oRng = ActiveDocument.Range
oRng.InsertAfter "The project Name is: " & oProject.Name & "." & vbCr & vbCr
With oProject
For i = 1 To .VBComponents.Count
oRng.InsertAfter vbTab & "Component " & i & " " & Chr(150) & " Name: " _
& .VBComponents(i).Name & " Type: " & ComponentTypeToString(.VBComponents(i).Type) & vbCr
lngLineCount = .VBComponents(i).CodeModule.CountOfLines
If lngLineCount > 3 Then
strName = ""
lngLineNumber = 1
j = 1
Do
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Get)
If strName <> vbNullString Then
lngLineNumber = lngLineNumber + 1
Exit Do
End If
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Let)
If strName <> vbNullString Then
lngLineNumber = lngLineNumber + 1
Exit Do
End If
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Set)
If strName <> vbNullString Then
lngLineNumber = lngLineNumber + 1
Exit Do
End If
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
If strName <> vbNullString Then
lngLineNumber = lngLineNumber + 1
Exit Do
End If
lngLineNumber = lngLineNumber + 1
If lngLineNumber > lngLineCount Then Exit Do
Loop
If lngLineNumber < lngLineCount Then
oRng.InsertAfter vbTab & vbTab & "The procedure(s) in this component are:" & vbCr _
& vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
For lngLineNumber = lngLineNumber To lngLineCount
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Get)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Let)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If
If .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Proc) <> strName Then
j = j + 1
strName = .VBComponents(i).CodeModule.ProcOfLine(lngLineNumber, vbext_pk_Set)
oRng.InsertAfter vbTab & vbTab & vbTab & "Procedure " & j & ": " & strName & vbCr
End If

Next
Else
oRng.InsertAfter vbTab & vbTab & "There are no procedures in this component." & vbCr
End If
Else
oRng.InsertAfter vbTab & vbTab & "There are no procedures in this component." & vbCr
End If
oRng.InsertAfter vbCr
Next i
End With
Set oRng = Nothing
Set oProject = Nothing
End Sub
Sub ProjectModuleExport()
Dim oProject As VBProject
Dim strProject As String
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
With oProject
For i = 1 To .VBComponents.Count
MsgBox .VBComponents(i).Name
Select Case .VBComponents(i).Type
Case vbext_ct_StdModule, vbext_ct_ClassModule, vbext_ct_MSForm
.VBComponents(i).Export ("C:\" & .Name & "_" & .VBComponents(i).Name & ".bas")
Case Else
End Select
Next
End With
End Sub
Sub CopyMacroCodeToDoc()
Dim oRng As Word.Range
Dim oProject As VBProject
Dim strName As String
Dim i As Long
Dim lngLineNumber As Long
Dim j As Long
Dim lngLineCount As Long
Set oProject = ActiveDocument.VBProject
Set oRng = ActiveDocument.Range
oRng.InsertAfter oProject.Name & "." & vbCr & vbCr
With oProject
For i = 1 To .VBComponents.Count
oRng.InsertAfter .VBComponents(i).CodeModule.Lines(1, .VBComponents(i).CodeModule.CountOfLines)
Next i
End With
Set oRng = Nothing
Set oProject = Nothing
End Sub
Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String
Select Case ComponentType
Case vbext_ct_ActiveXDesigner
ComponentTypeToString = "ActiveX Designer"
Case vbext_ct_ClassModule
ComponentTypeToString = "Class Module"
Stop
Case vbext_ct_Document
ComponentTypeToString = "Document Module"
Case vbext_ct_MSForm
ComponentTypeToString = "UserForm"
Case vbext_ct_StdModule
ComponentTypeToString = "Code Module"
Case Else
ComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
End Select
End Function

[gmaxey]

You might want to use something like:

Dim oTmpDoc as Document
Set oTmpDoc = vFile.OpenAsDocument
'do your stuff
oTmpDoc

[johndavidson]

Greg - Excellent. That does the trick.

Thanks for your help

John

[johndavidson]

So there isn't a way of doing it without actually opening the template as a document? I was hoping to be able to read the module names etc. through the templates collection, as one can do when making hotkey changes, for example. Feels a little safer that way.

John

[gmaxey]

No, not that I know of.

[johndavidson]

Greg - It's all working fine now. Thanks for the help. I'll post the code in a few days.

John

[johndavidson]

Greg - Here's the package, some of it based on your code. Nothing very elaborate. Provides these routines:

commandBarList List all command bars and derivatives, and code modules, in a new document. Helps to keep track of which macros are associated with which toolbar/menu items.

projectList List all code modules in all user templates.

procedureList List all procedures (macros etc.) in all user templates.

copyMacroCodeToDoc Copy all macro code from current document to new document

projectModuleExport Exports the modules from the active document (if any) to the C:\ drive root folder.

John

[johndavidson]

This is an updated version of the code. Does the same thing, just a little tidier.

[johndavidson]

This update fixes an issue with the Today routine that occurs in some setups. Also prevents the templates being added to the RecentFiles list.