Vielen Dank für eure Hilfe
Kalla
es haben nur wenige hier eine Glaskugel oder Heiligenschein. Für alle anderen wäre der Code schon hilfreich.
Der Code wurde getestet unter Betriebssystem XP Pro und Excel Version XP SBE.
Bitte kein Mail, Probleme sollen im Forum gelöst werden.
Microsoft MVP für Excel
Dim oPopUp As CommandBarControl, oBtn As CommandBarButton, cbar As CommandBar, _
dd As CommandBarComboBox
Public Cdb$()
Sub messeneu_erstellen()
Set cbar = Application.CommandBars.Add("Messeneu2", msoBarTop)
With cbar
.Visible = True
.Protection = msoBarNoCustomize
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Speichern und Excel beenden"
.FaceId = 270
.OnAction = "speichern_beenden"
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=109)
With oBtn
.Caption = "Seitenansicht, Druckvorschau"
.OnAction = "Seitenansicht"
End With
Set oPopUp = Application.CommandBars("Messeneu2").Controls.Add(msoControlPopup)
With oPopUp
.Caption = "Drucken ..."
.BeginGroup = True
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Alle Einträge drucken"
.OnAction = "Druckfilter"
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Markierung drucken"
.OnAction = "Mehrbereichsdruck"
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Blattschutz ausschalten"
.FaceId = 277
.OnAction = "Blattschutz_aus"
.Visible = True
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Blattschutz einschalten"
.FaceId = 225
.OnAction = "Blattschutz_ein"
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=855)
Set dd = Application.CommandBars("Messeneu2").Controls.Add(msoControlComboBox, Id:=1731)
With dd
.Width = 35
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=113)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=114)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=115)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=120)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=122)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=121)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Hintergrund- oder Schriftfarbe einstellen"
.FaceId = 417
.OnAction = "ColorPicker"
.BeginGroup = True
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=398)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=399)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=541)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=542)
End Sub
Sub leisten_löschen()
Dim i%
For Each cbar In Application.CommandBars
If cbar.Type <> msoBarTypeMenuBar Then
If cbar.Visible Then
On Error Resume Next
i = i + 1
ReDim Preserve Cdb(i)
Cdb(i) = cbar.Name
cbar.Visible = False
End If
End If
Next cbar
Application.CommandBars("Messeneu").Visible = True
Application.CommandBars("Messeneu2").Visible = True
Application.CommandBars("Messeneu3").Visible = True
Application.CommandBars("Worksheet Menu Bar").Enabled = False
Application.CommandBars("Ply").Enabled = False
Application.DisplayStatusBar = False
End Sub
Sub leisten_wieder_herstellen()
Dim i%
On Error GoTo errorhandler
Application.CommandBars("Messeneu").Delete
Application.CommandBars("Messeneu2").Delete
Application.CommandBars("Messeneu3").Delete
errorhandler:
On Error GoTo errorhandler2
Application.DisplayAlerts = False
For i = 1 To UBound(Cdb)
Application.CommandBars(Cdb(i)).Visible = True
Next i
Application.DisplayAlerts = True
errorhandler2:
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Worksheet Menu Bar").Controls("Extras").Visible = True
Application.CommandBars("Ply").Enabled = True
Application.DisplayStatusBar = True
Application.CommandBars("Cell").Reset
End Sub
Dim oPopUp As CommandBarControl, oBtn As CommandBarButton, cbar As CommandBar, _
dd As CommandBarComboBox
Public Cdb$()
Sub messeneu_erstellen()
Set cbar = Application.CommandBars.Add("Messeneu2", msoBarTop)
With cbar
.Visible = True
.Protection = msoBarNoCustomize
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Speichern und Excel beenden"
.FaceId = 270
.OnAction = "speichern_beenden"
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=109)
With oBtn
.Caption = "Seitenansicht, Druckvorschau"
.OnAction = "Seitenansicht"
End With
Set oPopUp = Application.CommandBars("Messeneu2").Controls.Add(msoControlPopup)
With oPopUp
.Caption = "Drucken ..."
.BeginGroup = True
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Alle Einträge drucken"
.OnAction = "Druckfilter"
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Markierung drucken"
.OnAction = "Mehrbereichsdruck"
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Blattschutz ausschalten"
.FaceId = 277
.OnAction = "Blattschutz_aus"
.Visible = True
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Blattschutz einschalten"
.FaceId = 225
.OnAction = "Blattschutz_ein"
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=855)
Set dd = Application.CommandBars("Messeneu2").Controls.Add(msoControlComboBox, Id:=1731)
With dd
.Width = 35
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=113)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=114)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=115)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=120)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=122)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=121)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add
With oBtn
.Caption = "Hintergrund- oder Schriftfarbe einstellen"
.FaceId = 417
.OnAction = "ColorPicker"
.BeginGroup = True
.Visible = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=398)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=399)
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=541)
With oBtn
.BeginGroup = True
End With
Set oBtn = Application.CommandBars("Messeneu2").Controls.Add(msoControlButton, Id:=542)
End Sub
Sub leisten_löschen()
Dim i%
For Each cbar In Application.CommandBars
If cbar.Type <> msoBarTypeMenuBar Then
If cbar.Visible Then
On Error Resume Next
i = i + 1
ReDim Preserve Cdb(i)
Cdb(i) = cbar.Name
cbar.Visible = False
End If
End If
Next cbar
Application.CommandBars("Messeneu").Visible = True
Application.CommandBars("Messeneu2").Visible = True
Application.CommandBars("Messeneu3").Visible = True
Application.CommandBars("Worksheet Menu Bar").Enabled = False
Application.CommandBars("Ply").Enabled = False
Application.DisplayStatusBar = False
End Sub
Sub leisten_wieder_herstellen()
Dim i%
On Error GoTo errorhandler
Application.CommandBars("Messeneu").Delete
Application.CommandBars("Messeneu2").Delete
Application.CommandBars("Messeneu3").Delete
errorhandler:
On Error GoTo errorhandler2
Application.DisplayAlerts = False
For i = 1 To UBound(Cdb)
Application.CommandBars(Cdb(i)).Visible = True
Next i
Application.DisplayAlerts = True
errorhandler2:
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Worksheet Menu Bar").Controls("Extras").Visible = True
Application.CommandBars("Ply").Enabled = True
Application.DisplayStatusBar = True
Application.CommandBars("Cell").Reset
End Sub
ich habe ein Problem damit, die Leisten nur aus und ein zu blenden. Wenn ich sie über Workbook_WindowActivate bzw. Workbook_WindowDeActivate ein und ausblende, muss ich sie über
workbook_close löschen (Eigene Symbolleisten sollen definitiv gelöscht werden). Wenn aber Excel beendet wird und die "Speichern"-Abfrage verneint wird, werden die Symbolleisten schon gelöscht, ohne dass Excel beendet wird. Nun stehen die Leute die mit dieser Datei arbeiten ohne Symbolleisten dar, weil ich alle Standardsymbolleisten und die Menüleiste ausblende.
Deswegen habe ich den Weg gewählt, die Symbolleisten bei Workbook_WindowActivate zu erstellen und bei Workbook_WindowDeActivate zu löschen.
Gruß
Kalla
Set cbar = Application.CommandBars.Add("Messeneu2", msoBarTop, Temporary:=True)
damit kannst du dir das löschen sparen.
Das aus bzw. einblenden legst du am besten in folgende Ereignisroutinen:
Workbook_Deactivate / Workbook_Activate
Gruß
Nepumuk
... anderthalb Stunden später:
Habe alles durchexerziert und den Fehler gefunden:
Die Zwischenablage wird durch ein- bzw. ausblenden der Status-Bar gelöscht: "Application.DisplayStatusBar = False" bzw. "true".
Vielen Dank für Eure Bemühungen und Hilfen,
bis demnächst,
Kalla