Gruppe
Menue
Problem
Beim Öffnen der Arbeitsmappe soll dem "Einfügen"-Menü ein neuer Menüpunkt "XKommentar" hinzugefügt werden. Bei Anklicken des Menüpunktes wird ein neuer Kommentar mit vorgegebener Schriftformatierung und selektiertem Anwendernamen erstellt.
ClassModule: DieseArbeitsmappe
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim oPopUp As CommandBarPopup
Set oPopUp = Application.CommandBars("Worksheet Menu Bar") _
.FindControl(ID:=30005)
On Error GoTo ERRORHANDLER
oPopUp.Controls("XKommentar").Delete
ERRORHANDLER:
End Sub
Private Sub Workbook_Open()
Dim oPopUpA As CommandBarPopup
Dim oPopUpB As CommandBarControl
Dim oBtn As CommandBarButton
Set oPopUpA = Application.CommandBars("Worksheet Menu Bar") _
.FindControl(ID:=30005)
For Each oPopUpB In oPopUpA.Controls
If InStr(WorksheetFunction _
.Substitute(oPopUpB.Caption, "&", ""), _
"Kommentar") Then Exit For
Next oPopUpB
On Error Resume Next
oPopUpA.Controls("XKommentar").Delete
On Error GoTo 0
Set oBtn = oPopUpA.Controls.Add(before:=oPopUpB.Index + 1)
With oBtn
.Caption = "XKommentar"
.OnAction = "SetComment"
.FaceId = 1591
.Style = msoButtonIconAndCaption
End With
End Sub
StandardModule: basMain
Sub SetComment()
Dim cmt As Comment
Set cmt = ActiveCell.AddComment
With cmt.Shape
.Height = 80
.Width = 120
With .TextFrame
With .Characters.Font
.Size = 12
.Bold = False
End With
End With
.Visible = True
SendKeys Application.UserName & ":+{home}"
.Select
End With
End Sub