G
Guest
sepecifically this macro has stopped working
Function Macro_Menu()
Dim vbcomp As VBComponent
Dim curMacro As String, newMacro As String
Dim i As Integer
Dim Menu As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim FirstExists As Boolean
On Error Resume Next
Application.CommandBars(1).Controls("Macros").Delete
Set Menu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=10, Temporary:=True)
Menu.Caption = "Macros"
curMacro = ""
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
If Right(vbcomp.Name, 7) <> "No_Menu" Then
If vbcomp.CodeModule.CountOfLines > 4 Then
If vbcomp.DesignerID <> "Forms.Form" Then
FirstExists = False
For i = 1 To vbcomp.CodeModule.CountOfLines
issuea = Right(vbcomp.CodeModule.Lines(i, 1), 7)
newMacro = vbcomp.CodeModule.ProcOfLine(i, vbext_pk_Proc)
If curMacro <> newMacro Then
curMacro = newMacro
If curMacro <> "" Then
If issuea <> "No Menu" Then
If Not FirstExists Then
Set MenuItem = Menu.Controls.Add(Type:=msoControlPopup)
MenuItem.Caption = vbcomp.Name
FirstExists = True
End If
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = newMacro
SubMenuItem.OnAction = vbcomp.Name & "." & newMacro
End If
End If
End If
Next
End If
End If
End If
Next
Exit_CWBM:
Exit Function
Err_CWBM:
On Error Resume Next
Resume Exit_CWBM
End Function
Function Macro_Menu()
Dim vbcomp As VBComponent
Dim curMacro As String, newMacro As String
Dim i As Integer
Dim Menu As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim FirstExists As Boolean
On Error Resume Next
Application.CommandBars(1).Controls("Macros").Delete
Set Menu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=10, Temporary:=True)
Menu.Caption = "Macros"
curMacro = ""
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
If Right(vbcomp.Name, 7) <> "No_Menu" Then
If vbcomp.CodeModule.CountOfLines > 4 Then
If vbcomp.DesignerID <> "Forms.Form" Then
FirstExists = False
For i = 1 To vbcomp.CodeModule.CountOfLines
issuea = Right(vbcomp.CodeModule.Lines(i, 1), 7)
newMacro = vbcomp.CodeModule.ProcOfLine(i, vbext_pk_Proc)
If curMacro <> newMacro Then
curMacro = newMacro
If curMacro <> "" Then
If issuea <> "No Menu" Then
If Not FirstExists Then
Set MenuItem = Menu.Controls.Add(Type:=msoControlPopup)
MenuItem.Caption = vbcomp.Name
FirstExists = True
End If
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = newMacro
SubMenuItem.OnAction = vbcomp.Name & "." & newMacro
End If
End If
End If
Next
End If
End If
End If
Next
Exit_CWBM:
Exit Function
Err_CWBM:
On Error Resume Next
Resume Exit_CWBM
End Function