AW: Makrosammlung automatisch in Menü einfügen
22.02.2012 12:22:43
Rudi
Hallo,
geht nur ohne Projektschutz.
Sub CreateMenu()
Dim arrSubs
Dim oBar As CommandBar, oPop As CommandBarPopup, oBtn As CommandBarButton
Dim iCounter As Integer
Const sBar As String = "TestBar"
arrSubs = MakroListe(ThisWorkbook)
On Error Resume Next
Application.CommandBars(sBar).Delete
On Error GoTo 0
Set oBar = Application.CommandBars.Add(sBar, msoBarTop, , True)
oBar.Visible = True
For iCounter = 1 To UBound(arrSubs)
Set oPop = oBar.FindControl(Tag:=arrSubs(iCounter, 2))
If oPop Is Nothing Then
Set oPop = oBar.Controls.Add(msoControlPopup)
With oPop
.Tag = arrSubs(iCounter, 2)
.Caption = arrSubs(iCounter, 2)
.BeginGroup = True
End With
End If
Set oBtn = oPop.Controls.Add(msoControlButton)
With oBtn
.Caption = arrSubs(iCounter, 1)
.OnAction = arrSubs(iCounter, 1)
.Style = msoButtonIconAndCaption
End With
Next
End Sub
Function MakroListe(wkb As Workbook)
Dim vbc As Object, iRow As Long, sText
Dim sName As String
Dim objSubs As Object, arrSubs, arrKeys, arrItems
Set objSubs = CreateObject("Scripting.Dictionary")
For Each vbc In wkb.VBProject.VBComponents
iRow = 1
If vbc.Type = 1 Then
With vbc.CodeModule
Do While iRow "" Then
sName = .ProcOfLine(iRow, 0)
If Not objSubs.exists(sName) Then
sText = Trim(.Lines(.ProcBodyLine(sName, 0), 1))
If Not sText Like "Private*" And Not sText Like "Function*" Then
If Right(sText, 2) = "()" Then
objSubs(sName) = vbc.Name
End If
End If
iRow = .ProcStartLine(sName, 0) + .ProcCountLines(sName, 0) - 1
End If
End If
iRow = iRow + 1
Loop
End With
End If
Next vbc
arrKeys = objSubs.keys
arrItems = objSubs.Items
ReDim arrSubs(1 To objSubs.Count, 1 To 2)
For iRow = 0 To UBound(arrKeys)
arrSubs(iRow + 1, 1) = arrKeys(iRow)
arrSubs(iRow + 1, 2) = arrItems(iRow)
Next
MakroListe = arrSubs
End Function
Gruß
Rudi