Gruppe
Menue
Problem
Wie kann ich eine benutzerdefinierte Funktion einer Symbolleistenschaltfläche zuweisen? Der Ablauf soll ähnlich sein, wie bei dem Excel-Feature AutoSumme.
ClassModule: DieseArbeitsmappe
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call CmdDelete
End Sub
Private Sub Workbook_Open()
Dim oPopUp As CommandBarPopup
Dim oBtn As CommandBarButton
Call CmdDelete
With Application.CommandBars("Worksheet Menu Bar")
Set oPopUp = .Controls.Add( _
Type:=msoControlPopup, _
before:=.Controls.Count, _
temporary:=True)
End With
oPopUp.Caption = "&Kubatur"
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Formel Eingabe"
.OnAction = "Cbm_Active_Formel"
.Style = msoButtonCaption
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Wert Eingabe"
.OnAction = "Cbm_Active_Wert"
.Style = msoButtonCaption
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Formel Auswahl"
.OnAction = "Cbm_Formel_Select"
.Style = msoButtonCaption
End With
Set oBtn = oPopUp.Controls.Add
With oBtn
.Caption = "Wert Auswahl"
.OnAction = "Cbm_Wert_Select"
.Style = msoButtonCaption
End With
End Sub
StandardModule: basMain
Function Kubatur(rng As Range) As Double
Kubatur = rng(1) * rng(2) * rng(3)
End Function
Sub Cbm_Active_Formel()
Dim iLen As Integer, sRng As String
With ActiveCell
If IsEmpty(.Offset(0, -1)) Or .Column < 4 Then
.Formula = "=kubatur()"
SendKeys "{F2}{left}"
Else
sRng = Range(Cells(.Row, .Column - 3), _
Cells(.Row, .Column - 1)).Address
iLen = Len(sRng)
.Formula = "=kubatur(" & sRng & ")"
SendKeys "{F2}{left}+{left " & iLen & "}"
End If
End With
End Sub
Sub Cbm_Active_Wert()
Dim iLen As Integer, sRng As String
With ActiveCell
If .Column < 4 Then
Beep
MsgBox "Die Funktion kann nur ab Spalte D genutzt werden!"
Else
ActiveCell.Value = Kubatur(Range(ActiveCell.Offset(0, -3), _
ActiveCell.Offset(0, -1)))
End If
End With
End Sub
Sub Cbm_Formel_Select()
Dim rng As Range
Set rng = Application.InputBox("Bereich:", Type:=8)
If rng.Cells.Count <> 3 Then
Beep
MsgBox "Sie benötigen Länge, Breite und Höhe -" & _
vbLf & "also bitte 3 Zellen auswählen!"
Exit Sub
End If
ActiveCell.Formula = "=kubatur(" & rng.Address & ")"
End Sub
Sub Cbm_Wert_Select()
Dim rng As Range
Set rng = Application.InputBox("Bereich:", Type:=8)
If rng.Cells.Count <> 3 Then
Beep
MsgBox "Sie benötigen Länge, Breite und Höhe -" & _
vbLf & "also bitte 3 Zellen auswählen!"
Exit Sub
End If
ActiveCell.Value = Kubatur(rng)
End Sub
Sub CmdDelete()
On Error GoTo ERRORHANDLER
Application.CommandBars("Worksheet Menu Bar") _
.Controls("&Kubatur").Delete
ERRORHANDLER:
End Sub