AW: Add In
20.08.2007 21:57:00
Type
Sub Auto_Open()
Dim BefehlsLeiste As CommandBar
Dim NeuesElement As CommandBarButton
On Error GoTo Fehler
ThisWorkbook.IsAddin = False
If CBDoesCBExist(strCBarName) = True Then
Exit Sub
Else
If Not SearchMenu("Meine") Then Call Menü_Hinzu
Set BefehlsLeiste = CommandBars.Add(Name:=strCBarName, Position:=msoBarLeft, temporary:=True)
BefehlsLeiste.Visible = True
Call AddCommandBarControlButton(strCBarName, "Optionen An Aus", "Optionen", 229)
Call AddCommandBarControlButton(strCBarName, "Kilometer", "KMFormat", 330)
Call AddCommandBarControlButton(strCBarName, "Meter", "mFormat", 25)
Call AddCommandBarControlButton(strCBarName, "Quadratmeter", "qmFormat", 26)
Call AddCommandBarControlButton(strCBarName, "Kubikmeter", "KubikmFormat", 27)
Call AddCommandBarControlButton(strCBarName, "Stunden", "StdFormat", 33)
Call AddCommandBarControlButton(strCBarName, "Liter", "LtFormat", 480)
Call AddCommandBarControlButton(strCBarName, "Uhr", "UhrFormat", 126)
Call AddCommandBarControlButton(strCBarName, "Secunden", "SecFormat", 734)
Call AddCommandBarControlButton(strCBarName, "Format", "SonntagZellen", 2170)
Call AddCommandBarControlButton(strCBarName, " ", "EuFormat", 8)
Call AddCommandBarControlButton(strCBarName, "Spalten einblenden", "SpaltenEinblenden", 1650)
Call AddCommandBarControlButton(strCBarName, "Spalten ausblenden", "SpaltenAusblenden", 1649)
Call AddCommandBarControlButton(strCBarName, "Zeilen einblenden", "ZeilenEinblenden", 1653)
Call AddCommandBarControlButton(strCBarName, "Zeilen ausblenden", "ZeilenAusblenden", 1652)
Call AddCommandBarControlButton(strCBarName, "Tage ermitteln", "Tage", 744)
Set NeuesElement = CommandBars(strCBarName).Controls.Add(Type:=msoControlButton, Id:=1695)
Set NeuesElement = CommandBars(strCBarName).Controls.Add(Type:=msoControlButton, Id:=458)
Set NeuesElement = CommandBars(strCBarName).Controls.Add(Type:=msoControlButton, Id:=485)
End If
ThisWorkbook.IsAddin = True
Exit Sub
Fehler:
MsgBox Err.Number & " " & Err.Description
End Sub
Sub Auto_close()
If CBDoesCBExist(strCBarName) = True Then
CBDeleteCommandBar strCBarName
End If
Sub MenüWeg()
MenuBars(xlWorksheet).Menus(strMenuName).Delete
'Application.CommandBars("MeinM").Delete
End Sub
Function HoleBild(Nr As Long)
Dim Pic As String
Pic = "Bild" & Nr
Sheets("TB").Shapes(Pic).Select
Selection.Copy
End Function
Sub Menü_Hinzu()
On Error GoTo Fehler
Dim neuesMenü As Object
Dim ML As CommandBar
Set ML = CommandBars("Worksheet Menu Bar") '(MenuBar)
Set neuesMenü = ML.Controls.Add(Type:=msoControlPopup, temporary:=True)
neuesMenü.Caption = strMenuName
neuesMenü.Tag = "Meine"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 1
With neuerEintrag
' .PasteFace
.FaceID = 229
.OnAction = "Optionen" '1
.Caption = "Optionen An Aus"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
HoleBild 25
With neuerEintrag
.PasteFace
' .FaceID = 673
.OnAction = "mFormat" '25
.Caption = "Meter"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
HoleBild 26
With neuerEintrag
.PasteFace
' .FaceID = 673
.OnAction = "qmFormat" '26
.Caption = "Quadratmeter"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
HoleBild 27
With neuerEintrag
.PasteFace
' .FaceID = 673
.OnAction = "KubikmFormat" '27
.Caption = "Kubikmeter"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 2
With neuerEintrag
' .PasteFace
.FaceID = 330
.OnAction = "KMFormat" '2
.Caption = "Kilometer"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 3
With neuerEintrag
' .PasteFace
.FaceID = 33
.OnAction = "StdFormat" '3
.Caption = "Stunden"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 4
With neuerEintrag
' .PasteFace
.FaceID = 480
.OnAction = "LtFormat" '4
.Caption = "Liter"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 5
With neuerEintrag
' .PasteFace
.FaceID = 126
.OnAction = "UhrFormat" '5
.Caption = "Uhr"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 6
With neuerEintrag
' .PasteFace
.FaceID = 734
.OnAction = "SecFormat" '6
.Caption = "Secunden"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
' HoleBild 7
With neuerEintrag
' .PasteFace
.FaceID = 2170
.OnAction = "SonntagZellen" '7
.Caption = "Format"
.Tag = "Sonntag"
End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton)
HoleBild 8
With neuerEintrag
.PasteFace
' .FaceID = 395
.TooltipText = " Euroformat"
.OnAction = "EuFormat" '8
.Caption = " Euro"
.Tag = "Euro"
End With
' With NeuesElement
'' .PasteFace
' .Style = msoButtonCaption
' .BuiltInFace = True
' .FaceId = 588
' .TooltipText = " Euroformat"
' .Caption = ""
' .Tag = "Euro"
' .OnAction = "EuFormat" '8
' End With
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Id:=1695)
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Id:=458)
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Id:=485)
Exit Sub
Fehler:
MsgBox Err.Number & " " & Err.Description
End Sub
Private Function SearchMenu(srchTag As String) As Boolean
SearchMenu = True
'Set cbr = CommandBars("Menu Bar")
Dim myMenu
Set myMenu = CommandBars.FindControl(Type:=msoControlPopup, Tag:=srchTag)
If myMenu Is Nothing Then SearchMenu = False
End Function
Function AddCommandBarControlButton(strCommandBarName As String, strButtonCaption As String, strFunction As String, Optional FaceID As Long) ', Optional lngID As Long
' Diese Prozedur fügt eine neue Steuerelement-Schaltfläche zur Befehlsleiste
' hinzu, die in der strCommandBarName-Variablen angegeben ist, und
' legt ihre Eigenschaften "Caption", "Style","FaceID" und "OnAction" fest.
Dim cmdBar As CommandBar
Dim ctlNew As CommandBarButton
On Error Resume Next
Set cmdBar = CommandBars(strCommandBarName)
Set ctlNew = cmdBar.Controls.Add(msoControlButton)
Select Case FaceID
Case Is = 8, 25, 26, 27
HoleBild FaceID
ctlNew.PasteFace
ctlNew.Caption = strButtonCaption
ctlNew.OnAction = strFunction
Exit Function
End Select
ctlNew.FaceID = FaceID
ctlNew.Caption = strButtonCaption
' ctlNew.Style = msoButtonIconAndCaption
ctlNew.OnAction = strFunction
End Function