Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Symbolleiste zum Aufruf externer Anwendungen erstellen

Gruppe

Bar

Problem

Über ein Schaltfläche soll eine Symbolleiste gem. Tabelle erstellt werden. Bei Anklicken eines der Menüpunkte wird die in Spalte A genannte Anwendung mit der in Spalte C genannten Datei aus dem in Spalte E genannten Verzeichnis aufgerufen.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn den Schaltflächen zu.

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   On Error GoTo ERRORHANDLER
   Application.CommandBars("ApplicationsBar").Delete
ERRORHANDLER:
End Sub

StandardModule: Modul1

Sub CreateCmdBar()
   Dim oBar As CommandBar
   Dim oPopUp As CommandBarPopup
   Dim oBtn As CommandBarButton
   Dim iRow As Integer, iRowL As Integer
   On Error Resume Next
   Application.CommandBars("ApplicationsBar").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add("ApplicationsBar", msoBarTop)
   iRowL = Cells(Rows.Count, 4).End(xlUp).Row
   For iRow = 2 To iRowL
      If Not IsEmpty(Cells(iRow, 1)) Then
         Set oPopUp = oBar.Controls.Add(msoControlPopup)
         oPopUp.Caption = Cells(iRow, 2).Value
         Do
            Set oBtn = oPopUp.Controls.Add
            With oBtn
               .Style = msoButtonIconAndCaption
               .Caption = Cells(iRow, 3).Value
               .FaceId = Cells(iRow, 4).Value
               .OnAction = "GetFile"
               .DescriptionText = Cells(iRow, 5).Value
               .Tag = Cells(iRow, 1).Value
            End With
            iRow = iRow + 1
            If iRow > iRowL Then Exit Do
         Loop While IsEmpty(Cells(iRow, 1))
         iRow = iRow - 1
      End If
   Next iRow
   oBar.Visible = True
End Sub

Sub GetFile()
   Dim oBtn As CommandBarButton
   Dim sFile As String
   Set oBtn = Application.CommandBars.ActionControl
   sFile = oBtn.DescriptionText & "\" & oBtn.Caption
   If Dir(sFile) = "" Then
      Beep
      MsgBox "Die Datei " & sFile & " wurde nicht gefunden!"
      Exit Sub
   End If
   If Dir(oBtn.Tag) = "" Then
      Beep
      MsgBox "Die Anwendung " & oBtn.Tag & " wurde nicht gefunden!"
      Exit Sub
   End If
   Shell oBtn.Tag & " " & sFile, vbMaximizedFocus
End Sub

Sub DeleteCommandBar()
   On Error GoTo ERRORHANDLER
   Application.CommandBars("ApplicationsBar").Delete
ERRORHANDLER:
End Sub

    

Beiträge aus dem Excel-Forum zu den Themen Menue und Bar