AW: Menüleiste
16.07.2003 21:05:40
Hajo_Zi
Hallo Sabine
mal als Ansatz
' **************************************************************
' Modul: DieseArbeitsmappe Typ = Element der Mappe(Sheet, Workbook, ...)
' **************************************************************
'©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©'
'# Dieses Beispiel stammt aus: #'
'# Das Excel-VBA-Codebook #'
'# Autoren: Monika Weber und Bert Körn #'
'# ISBN: 3-8273-1979-X #'
'# #'
'# Alle Rechte vorbehalten #'
'# #'
'# Anfragen unter: #'
'# Monika@jumper.ch oder Bert@bert-koern.de #'
'# #'
'©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©'
Option Explicit
Private Sub Workbook_Open()
Dim cmbMenu As CommandBar
Dim cbcMenu As CommandBarControl
Dim cbcHintergrund As CommandBarControl
Dim cbcSchrift As CommandBarControl
Dim cbcHFRot As CommandBarControl
Dim cbcHFGruen As CommandBarControl
Dim cbcHFBlau As CommandBarControl
Dim cbcHFGelb As CommandBarControl
Dim cbcHFxlNone As CommandBarControl
Dim cbcSFRot As CommandBarControl
Dim cbcSFGruen As CommandBarControl
Dim cbcSFBlau As CommandBarControl
Dim cbcSFGelb As CommandBarControl
Dim cbcSFxlNone As CommandBarControl
Set cmbMenu = Application.CommandBars.ActiveMenuBar
Set cbcMenu = cmbMenu.Controls.Add(Type:=msoControlPopup)
cbcMenu.Caption = "Farbauswahl"
Set cbcHintergrund = cbcMenu.CommandBar.Controls.Add(Type:=msoControlPopup)
cbcHintergrund.Caption = "Hintergrund"
Set cbcSchrift = cbcMenu.CommandBar.Controls.Add(Type:=msoControlPopup)
cbcSchrift.Caption = "Schrift"
' Menü-Unterpunkt für die Hintergrundfarbe
Set cbcHFRot = cbcHintergrund.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcHFGruen = cbcHintergrund.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcHFBlau = cbcHintergrund.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcHFGelb = cbcHintergrund.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcHFxlNone = cbcHintergrund.CommandBar.Controls.Add(Type:=msoControlButton)
With cbcHFRot
.Caption = "Rot"
.OnAction = "HFRot"
End With
With cbcHFGruen
.Caption = "Grün"
.OnAction = "HFGruen"
End With
With cbcHFBlau
.Caption = "Blau"
.OnAction = "HFBlau"
End With
With cbcHFGelb
.Caption = "Gelb"
.OnAction = "HFGelb"
End With
With cbcHFxlNone
.Caption = "Hintergrund-Farbe entfernen"
.OnAction = "HFFarbeEntfernen"
End With
' Menü-Unterpunkt für die Schriftfarbe
Set cbcSFRot = cbcSchrift.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcSFGruen = cbcSchrift.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcSFBlau = cbcSchrift.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcSFGelb = cbcSchrift.CommandBar.Controls.Add(Type:=msoControlButton)
Set cbcSFxlNone = cbcSchrift.CommandBar.Controls.Add(Type:=msoControlButton)
With cbcSFRot
.Caption = "Rot"
.OnAction = "SFRot"
End With
With cbcSFGruen
.Caption = "Grün"
.OnAction = "SFGruen"
End With
With cbcSFBlau
.Caption = "Blau"
.OnAction = "SFBlau"
End With
With cbcSFGelb
.Caption = "Gelb"
.OnAction = "SFGelb"
End With
With cbcSFxlNone
.Caption = "Schrift-Farbe entfernen"
.OnAction = "SFFarbeEntfernen"
End With
' Ergänzung
Set cmbMenu = Nothing
Set cbcMenu = Nothing
Set cbcHintergrund = Nothing
Set cbcSchrift = Nothing
' Menü-Unterpunkt für die Hintergrundfarbe
Set cbcHFRot = Nothing
Set cbcHFGruen = Nothing
Set cbcHFBlau = Nothing
Set cbcHFGelb = Nothing
Set cbcHFxlNone = Nothing
' Menü-Unterpunkt für die Schriftfarbe
Set cbcSFRot = Nothing
Set cbcSFGruen = Nothing
Set cbcSFBlau = Nothing
Set cbcSFGelb = Nothing
Set cbcSFxlNone = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls("Farbauswahl").Delete
End Sub
' **************************************************************
' Modul: Modul1 Typ = Allgemeines Modul
' **************************************************************
'©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©'
'# Dieses Beispiel stammt aus: #'
'# Das Excel-VBA-Codebook #'
'# Autoren: Monika Weber und Bert Körn #'
'# ISBN: 3-8273-1979-X #'
'# #'
'# Alle Rechte vorbehalten #'
'# #'
'# Anfragen unter: #'
'# Monika@jumper.ch oder Bert@bert-koern.de #'
'# #'
'©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©©'
Option Explicit
Sub HFRot()
Selection.Interior.ColorIndex = 3
End Sub
Sub HFGruen()
Selection.Interior.ColorIndex = 4
End Sub
Sub HFBlau()
Selection.Interior.ColorIndex = 5
End Sub
Sub HFGelb()
Selection.Interior.ColorIndex = 6
End Sub
Sub HFFarbeEntfernen()
Selection.Interior.ColorIndex = xlNone
End Sub
Sub SFRot()
Selection.Font.ColorIndex = 3
End Sub
Sub SFGruen()
Selection.Font.ColorIndex = 4
End Sub
Sub SFBlau()
Selection.Font.ColorIndex = 5
End Sub
Sub SFGelb()
Selection.Font.ColorIndex = 6
End Sub
Sub SFFarbeEntfernen()
' geändert da Laufzeifehler
' Selection.Font.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
End Sub
Code eingefügt mit: Excel Code Jeanie
Falls Code vorhanden wurde dieser 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
Das Forum lebt auch von den Rückmeldungen.