Automatisch neue Symbolleiste mit Befehlen erstellen

19.02.2000


Folgende Routine, als Add-In einsetzbar, erstellt eine neue Symbolleiste,
falls diese noch nicht vorhanden ist.
Diese Symbolleiste wird mit 2 neuen Symbolen versehen,
die beide eine entsprechende Sub zugewiesen bekommen.

Es ist ein sofort einsetzbares Add-In,
welches Sonderzeichen einfügt:

   

Schritt 1
Öffnen Sie eine neue leere Arbeitsmappe

Schritt 2
In "Tabelle1" fügen Sie über die Zwischenablage
2 Symbole ein, die Sie zuvor in einer Grafikbearbeitungssoftware
erstellt haben.
Ein Tipp dazu: Kopieren Sie sich zunächst ein vorhandenes Symbol
aus einer Symbolleiste in Excel, um die genaue Größe zu kennen.
Benennen Sie diese Symbole mit "Symbol1" und "Symbol2".

Schritt 3
 Wechseln Sie nun in den Visual Basic Editor (Alt+F11)
Unter "DieseArbeitsmappe" fügen Sie im Codefenster
folgendes ein:

 Const Symbolleistenname = "Sonderzeichen"
Const Caption_1 = "&Durchmesserzeichen"
Const Caption_2 = "&Toleranz"

Private Sub Workbook_Open()
   On Error Resume Next
   Dim CB As CommandBar
   Dim CMB As CommandBarButton
   Set CB = Application.CommandBars(Symbolleistenname)
   'Symbolleiste ist nicht vorhanden
   If Err.Number <> 0 Then
      Application.CommandBars(Symbolleistenname).Delete
      Set CB = Application.CommandBars.Add(Name:= _
         Symbolleistenname, temporary:=False, Position:=msoBarTop)
      Set CMB = CB.Controls.Add(Type:=msoControlButton)
      '1. Symbol
      With CMB
         .Caption = Caption_1
         .OnAction = "Durchmesserzeichen"
          ThisWorkbook.Sheets("Tabelle1").Shapes _
            ("Symbol1").Copy
          Application.CommandBars(Symbolleistenname)._
           Controls(1).PasteFace
      End With
      '2. Symbol
      Set CMB = CB.Controls.Add(Type:=msoControlButton)
      With CMB
         .Caption = Caption_2
         .OnAction = "PlusMinus"
         ThisWorkbook.Sheets("Tabelle1").Shapes("Symbol2").Copy
         Application.CommandBars(Symbolleistenname)._
           Controls(2).PasteFace
      End With
     CB.Visible = True
   End If
End Sub


Schritt 4
 Fügen Sie ein neues Modul ein,
welches die Routinen beinhalten soll, die beim Klick auf die
jeweiligen Schaltflächen ausgeführt werden:

Sub Durchmesserzeichen()
   'falls keine Datei geöffnet ist
   If Workbooks.Count = 0 Then
      MsgBox "Es ist keine Datei geöffnet !", vbCritical, "Hinweis"
      Exit Sub
   End If
   'aktuellen Wert ermitteln
   Merk = ActiveCell.Value
   With ActiveCell
      'steht etwas darin ?
      If Len(Merk) > 0 Then
         'ist das 1. Zeichen kein Durchmesserzeichen,
         'dann Durchmesserzeichen voran stellen
         If Asc(Mid(Merk, 1, 1)) <> 198 Then  .Value = "Æ " & Merk
      Else
         'ansonsten nur Durchmesserzeichen
         .Value = "Æ "
      End If
      '1. Zeichen auf Schriftart "Symbol" setzen
      .Characters(Start:=1, Length:=1).Font.Name = "Symbol"
      'restliche Zeichen mit Schriftart "Arial"
      .Characters(Start:=3, Length:=100).Font.Name = "Arial"
   End With
End Sub

Sub PlusMinus()
   'falls keine Datei geöffnet ist
   If Workbooks.Count = 0 Then
      MsgBox "Es ist keine Datei geöffnet !", vbCritical, "Hinweis"
      Exit Sub
   End If
   'aktuellen Wert ermitteln
   Merk = ActiveCell.Value
   With ActiveCell
      'steht etwas darin ?
      If Len(Merk) > 0 Then
         'ist das 1. Zeichen kein "±",
         'dann "±" voran stellen
         If Asc(Mid(Merk, 1, 1)) <> 241 Then .Value = "± " & Merk
      Else
         'ansonsten nur Durchmesserzeichen
         .Value = "± "
      End If
   End With
End Sub

Schritt 5
Zum Schluss speichern Sie die Datei ab und können Sie als
Add-In einbinden.

 
Download - 13 KB