Menüleiste umbenennen...
03.01.2005 10:08:49
Karsten
Mein Problem:
Ich erstelle beim Öffnen einer Datei eine Menüleiste, die den Namen der Datei erhält. Beim Umbenennen der Datei soll aber die Menüleiste auch umbenannt werden, so daß sie weiterhin ansprechbar per VBA bleibt. Mittels Before_Save-Ereignis wird zunächst die alte Menüleiste gelöscht und dann eine neue Menuleiste erstellt. Da zum Zeitpunkt des Eintretens des Before_Save-Ereignisse der neue Dateiname noch nicht feststeht (die Abfrage des Speichern-Unter-Dialogs erfolgt ja erst danach) wird nun leider die neue Menüleiste mit dem alten Dateinamen erstellt und ist später nicht mehr per VBA ansprechbar.
Kann mir hier jemand helfen? Nachstehend mein Code.
Danke Karsten
Private Sub Workbook_Open()
'eigene Symbolleiste anlegen für die Bohrprofilerstellung
Dim symb As CommandBar
Dim symbol As CommandBarButton
Dim Name As String
On Error Resume Next
Worksheets("Icons").Activate
Worksheets("Icons").Shapes("Profilzeichnen").Select
Name = ActiveWorkbook.Name
Application.CommandBars(Name).Delete 'Zunächst event. vorhandene Menüleiste Löschen, damit nicht mehrere aufgemacht werden
Set symb = Application.CommandBars.Add(Name, Position:=msoBarTop, Temporary:=True)
ActiveWindow.Zoom = 100
With symb
.Left = 0
.Visible = True
End With
CalcStatus = Application.Calculation
Application.Calculation = xlAutomatic
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
With symbol
.Style = msoButtonIconAndCaption
.FaceId = 230
.Caption = "Projektdaten"
.TooltipText = "Eingabe der Projektdaten"
.BeginGroup = True
.OnAction = "ProjektdatenEingeben"
End With
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
With symbol
.Style = msoButtonIconAndCaption
.FaceId = 162
.Caption = "Bohrungsdaten"
.TooltipText = "Eingabemaske der Bohrungs- und Schichtdaten"
.BeginGroup = True
.OnAction = "Testuserform"
End With
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
Worksheets("Icons").Shapes("Profilzeichnen").Select
Selection.Copy
With symbol
.Style = msoButtonIconAndCaption
.PasteFace
.Caption = "Bohrprofil erstellen"
.TooltipText = "Bohrprofil"
.BeginGroup = True
.OnAction = "BohrprofilErstellen"
End With
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
Worksheets("Icons").Shapes("Schichtenverzeichnis").Select
Selection.Copy
With symbol
.Style = msoButtonIconAndCaption
.PasteFace
.Caption = "Schichtenverzeichnis"
.TooltipText = "Erstellung von Schichtenverzeichnissen nach DIN 4022"
.BeginGroup = True
.OnAction = "SchichtenverzeichnisErstellen"
End With
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
With symbol
.Style = msoButtonIconAndCaption
.FaceId = 279
.Caption = "Zwischenablage"
.TooltipText = "Kopieren der Grafik in die Zwischenablage"
.BeginGroup = True
.OnAction = "ZeichenobjekteKopieren"
End With
Set symbol = Application.CommandBars(Name).Controls.Add(Type:=msoControlButton)
With symbol
.Style = msoButtonIconAndCaption
.FaceId = 25
.Caption = "Grafikeinstellung"
.TooltipText = "Anpassen der Grafikausgabe an den Rechner"
.BeginGroup = True
.OnAction = "TestGrafik"
End With
Worksheets("Splash").Activate
End Sub
Private Sub Workbook_Activate()
'Symbolleiste bim Aktivieren der Mappe einblenden
On Error Resume Next
Application.CommandBars(Name).Enabled = True
CalcStatus = Application.Calculation
Application.Calculation = xlAutomatic
End Sub
Private Sub Workbook_Deactivate()
'Symbolleiste beim Wechseln auf anderes Blatt ausblenden
On Error Resume Next
Application.CommandBars(Name).Enabled = False
Application.Calculation = CalcStatus
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Beim Schließen der Datei die Symbolleiste wieder entfernen
On Error Resume Next
Application.CommandBars(Name).Delete
Application.Calculation = CalcStatus
End Sub
Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean)
'Um Komlikationen mit der Menüleiste zu vermeiden, diese beim Speichern neu erstellen
On Error Resume Next
If SaveAsUi = False Then
Exit Sub
End If
Workbook_Open
End Sub