AW: eigene menüleiste und standardmenüpunkte
04.05.2007 09:12:58
Rudi
Hallo,
zum Anzeigen der Face-Ids: https://www.herber.de/tools/symbolpicker.zip
Die Ids der Commandbarbuttons (nicht schön aber wirkungsvoll):
Public Sub Zeig_Alles()
' Listet alle CommandbarControls in einer eigenen Commandbar auf
'Code: ransi
Dim reset As CommandBarControl
Dim cb As CommandBar
Dim c As CommandBar
Dim a As CommandBar 'Zähler
Dim b As CommandBarControl
Dim cneu As CommandBarControl 'neu
Dim d As CommandBarControl 'Zähler
Dim e As CommandBarControl 'neu
Dim f As CommandBarControl 'Zähler
Dim g As CommandBarControl 'neu
Dim h As CommandBarControl 'zähler
Dim i As CommandBarControl 'neu
Dim j As CommandBarControl
Dim k As CommandBarControl
Dim vb As CommandBarControl
On Error Resume Next
DoEvents
Application.ScreenUpdating = False
For Each cb In Application.CommandBars
If cb.Name = "Alle Infos" Then cb.Delete
Next
Set c = Application.CommandBars.Add(Name:="Alle Infos")
Set b = c.Controls.Add(10)
Set vb = c.Controls.Add(10)
Set reset = c.Controls.Add(1)
b.Caption = "ID's "
vb.Caption = "VBE's"
With reset 'für Neuberechnung
.Caption = "Reset"
.Style = msoButtonIconAndCaption
.FaceId = 940
.OnAction = "Zeig_alles"
End With
c.Visible = True
For Each a In Application.CommandBars
If a.Name "Alle Infos" Then
Set cneu = b.Controls.Add(Type:=msoControlPopup)
cneu.Caption = a.NameLocal ' & " ID:=" & a.ID & ", Type:= " & a.Type'ab XP funzt das _
auch
If a.Controls.Count > 0 Then
For Each d In a.Controls
If Not d Is Nothing Then
Set e = cneu.Controls.Add(Type:=IIf(d.Type = 1, 1, 10))
With e 'Eigenschaften des Originals abschreiben
.Caption = d.Caption & " ID:=" & d.ID & ", Type:= " & d.Type
.Style = d.Style
.FaceId = d.FaceId
.BeginGroup = d.BeginGroup
End With
End If
If d.Controls.Count > 0 Then
For Each f In d.Controls
If Not f Is Nothing Then
Set g = e.Controls.Add(Type:=IIf(f.Type = 1, 1, 10))
With g 'Eigenschaften des Originals abschreiben
.Caption = f.Caption & " ID:=" & f.ID & ", Type:= " & f.Type
.Style = f.Style
.FaceId = f.FaceId
.BeginGroup = f.BeginGroup
End With
End If
If f.Controls.Count > 0 Then
For Each h In f.Controls
If Not h Is Nothing Then
Set i = g.Controls.Add(Type:=IIf(h.Type = 1, 1, 10))
With i 'Eigenschaften des Originals abschreiben
.Caption = h.Caption & " ID:=" & h.ID & ", Type:= " & h.Type
.Style = h.Style
.FaceId = h.FaceId
.BeginGroup = h.BeginGroup
End With
End If
For Each j In h.Controls
If Not j Is Nothing Then
Set k = i.Controls.Add(Type:=IIf(j.Type = 1, 1, 10))
With k
.Caption = j.Caption & " ID:=" & j.ID & ", Type:= " & j.Type
.Style = j.Style
.FaceId = j.FaceId
.BeginGroup = j.BeginGroup
End With
End If
Next
Next
End If
Next
End If
Next
End If
End If
Next
Set a = Nothing
Set reset = Nothing
Set cb = Nothing
Set c = Nothing
Set d = Nothing
Set cneu = Nothing
Set e = Nothing
Set f = Nothing
Set g = Nothing
Set h = Nothing
Set i = Nothing
Set j = Nothing
Set k = Nothing
For Each a In Application.VBE.CommandBars
If a.Name "Alle Infos" Then
Set cneu = vb.Controls.Add(Type:=msoControlPopup)
cneu.Caption = a.NameLocal '& " ID:=" & a.ID & ", Type:= " & a.Type
If a.Controls.Count > 0 Then
For Each d In a.Controls
If Not d Is Nothing Then
Set e = cneu.Controls.Add(Type:=IIf(d.Type = 1, 1, 10))
With e 'Eigenschaften des Originals abschreiben
.Caption = d.Caption & " ID:=" & d.ID & ", Type:= " & d.Type
.Style = d.Style
.FaceId = d.FaceId
.BeginGroup = d.BeginGroup
End With
End If
If d.Controls.Count > 0 Then
For Each f In d.Controls
If Not f Is Nothing Then
Set g = e.Controls.Add(Type:=IIf(f.Type = 1, 1, 10))
With g 'Eigenschaften des Originals abschreiben
.Caption = f.Caption & " ID:=" & f.ID & ", Type:= " & f.Type
.Style = f.Style
.FaceId = f.FaceId
.BeginGroup = f.BeginGroup
End With
End If
If f.Controls.Count > 0 Then
For Each h In f.Controls
If Not h Is Nothing Then
Set i = g.Controls.Add(Type:=IIf(h.Type = 1, 1, 10))
With i 'Eigenschaften des Originals abschreiben
.Caption = h.Caption & " ID:=" & h.ID & ", Type:= " & h.Type
.Style = h.Style
.FaceId = h.FaceId
.BeginGroup = h.BeginGroup
End With
End If
For Each j In h.Controls
If Not j Is Nothing Then
Set k = i.Controls.Add(Type:=IIf(j.Type = 1, 1, 10))
With k
.Caption = j.Caption & " ID:=" & j.ID & ", Type:= " & j.Type
.Style = j.Style
.FaceId = j.FaceId
.BeginGroup = j.BeginGroup
End With
End If
Next
Next
End If
Next
End If
Next
End If
End If
Next
Application.ScreenUpdating = True
Set a = Nothing
Set reset = Nothing
Set cb = Nothing
Set c = Nothing
Set d = Nothing
Set cneu = Nothing
Set e = Nothing
Set f = Nothing
Set g = Nothing
Set h = Nothing
Set i = Nothing
Set j = Nothing
Set k = Nothing
Set vb = Nothing
End Sub
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe