Gruppe
Menue
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.
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