Gruppe
Menue
Bereich
Button
Thema
Neuer Menüpunkt mit Kommentar-einfügen-Befehl
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.
Lösung
Geben Sie den nachfolgenden Code in das Klassenmodul der Arbeitsmappe ein.
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