C:\Users\Administrator\AppData\Roaming\Microsoft\Excel\XL11A.xlsb

Private Sub NoteZoom3()
    With ActiveWindow.VisibleRange
         NoteChangeSize .Width, .Height, .Top, .Left, True
    End With
End Sub

Private Sub NoteChangeSize(w!, h!, Optional t!, Optional l!, Optional scr As Boolean)
    With ActiveCell.Comment.Shape
         .Width = w: .Height = h
         If scr Then .Top = t: .Left = l: .Visible = msoTrue
    End With
End Sub

Option Explicit

Private Sub Workbook_Open()
    Call ActivateRibbonTab(TabName:=[LastActiveRibbonTab])
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Names.Add "LastActiveRibbonTab", GetActiveRibbonTab
    Me.Save
End Sub

Private Function GetActiveRibbonTab() As String
    Const CHILDID_SELF = 0&, NAVDIR_FIRSTCHILD = 7&
    Const NAVDIR_LASTCHILD = 8&, NAVDIR_NEXT = 5&
    Const STATE_SELECTED = &H300002  
    Dim accObj As IAccessible, i As Long, j As Long, lChildCount As Long
     
    Set accObj = Application.CommandBars("Ribbon")
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
    lChildCount = accObj.accChildCount
    Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
    
    On Error Resume Next
    For i = 1 To lChildCount
        Set accObj = accObj.accNavigate(NAVDIR_NEXT, CHILDID_SELF)
        If UCase(accObj.accName(CHILDID_SELF)) = UCase("Ribbon Tabs") Then
            Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            lChildCount = accObj.accChildCount
            Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            For j = 1 To lChildCount
                Set accObj = accObj.accNavigate(NAVDIR_NEXT, CHILDID_SELF)
                If accObj.accState(0&) = STATE_SELECTED Then
                    GetActiveRibbonTab = accObj.accName(CHILDID_SELF)
                    Exit Function
                End If
            Next j
        End If
    Next i
End Function

Private Function ActivateRibbonTab(ByVal TabName As String) As Boolean

    Const CHILDID_SELF = 0&, NAVDIR_FIRSTCHILD = 7&
    Const NAVDIR_LASTCHILD = 8&, NAVDIR_NEXT = 5&
    Dim accObj As IAccessible, i As Long, j As Long, lChildCount As Long
    
    Set accObj = Application.CommandBars("Ribbon")
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_LASTCHILD, CHILDID_SELF)
    Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
    lChildCount = accObj.accChildCount
    Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
    
    On Error Resume Next
    For i = 1 To lChildCount
        Set accObj = accObj.accNavigate(NAVDIR_NEXT, CHILDID_SELF)
        If UCase(accObj.accName(CHILDID_SELF)) = UCase("Ribbon Tabs") Then
            Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            lChildCount = accObj.accChildCount
            Set accObj = accObj.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
            For j = 1 To lChildCount
                Set accObj = accObj.accNavigate(NAVDIR_NEXT, CHILDID_SELF)
                If UCase(accObj.accName(CHILDID_SELF)) = UCase(TabName) Then                
                    accObj.accDoDefaultAction CHILDID_SELF                    
                    ActivateRibbonTab = Not CBool(Err.Number)
                    Exit Function
                End If
            Next j
        End If
    Next i
End Function

Sub Note_FillColor_White()
Dim myComm As Comment
  If Not ActiveCell.Comment Is Nothing Then
    If MsgBox("Ячейка уже содержит примечание, удалить?", 4) - 7 Then
      ActiveCell.Comment.Delete
    Else: Exit Sub
    End If
  End If

Set myComm = ActiveCell.AddComment
    With myComm.Shape
      .Height = 110
      .Width = 200
      .Top = 55
      .AutoShapeType = 1             'форма
      .Fill.ForeColor.SchemeColor = 1 'заливка » Белый
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .DrawingObject.Font.Name = "Consolas"
      .DrawingObject.Font.FontStyle = "normal"
      .DrawingObject.Font.Size = 8
     End With
      'Эмулируем выбор пункта "Изменить `Заметку`"
       SendKeys "+{F2}"
End Sub

Sub CellColor()
Call CellColor_Do(0)
End Sub
 
Private Sub CellColor_Do(Undo As Integer)
Static xBook As Workbook, xSheet As Worksheet, xSelection As Range, xColor As Long
Const sName As String = "CellColor"
Const sUndo As String = "Undo Color in "
Const sRedo As String = "Redo Color in "
If Undo = 0 Then
    Set xBook = ActiveWorkbook
    Set xSheet = ActiveSheet
    Set xSelection = Selection
    xColor = Selection.Cells(1).Interior.Color
    xSelection.Show
    xSelection.Interior.Color = RGB(227, 38, 54)
    Application.OnUndo (sUndo + xSelection.Address(False, False)), (ThisWorkbook.Name + "!" + sName + "_Undo")
ElseIf xSelection Is Nothing Then
    Beep
Else
    xBook.Activate
    xSheet.Activate
    xSelection.Select
    xSelection.Show
    If Undo < 0 Then
        xSelection.Interior.Color = xColor
        Application.OnRepeat (sRedo + xSelection.Address(False, False)), (ThisWorkbook.Name + "!" + sName + "_Redo")
    Else
        xSelection.Interior.Color = RGB(227, 38, 54)
        Set xSelection = Nothing
    End If
End If
End Sub
 
Private Sub CellColor_Undo()
    Call CellColor_Do(-1)
End Sub
 
Private Sub CellColor_Redo()
    Call CellColor_Do(1)
End Sub

Sub Note_FillColor_White()
Dim myComm As Comment
  If Not ActiveCell.Comment Is Nothing Then
    If MsgBox("Ячейка уже содержит примечание, удалить?", 4) - 7 Then
      ActiveCell.Comment.Delete
    Else: Exit Sub
    End If
  End If
 
Set myComm = ActiveCell.AddComment
    With myComm.Shape
      .Height = 110
      .Width = 200
      .Top = 55
      .AutoShapeType = 1             'форма
      .Fill.ForeColor.SchemeColor = 1 'заливка » Белый
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .DrawingObject.Font.Name = "Consolas"
      .DrawingObject.Font.FontStyle = "normal"
      .DrawingObject.Font.Size = 8
     End With
      'Эмулируем выбор пункта "Изменить `Заметку`"
       SendKeys "+{F2}"
End Sub

Sub CoverCommentIndicator(control As IRibbonControl)
    'www.contextures.com/xlcomments03.html
    Dim ws As Worksheet
    Dim cmt As Comment
    Dim lCmt As Long
    Dim rngCmt As Range
    Dim shpCmt As Shape
    Dim shpW As Double 'ширина формы
    Dim shpH As Double 'высота формы
    
    Set ws = ActiveSheet
    shpW = 8
    shpH = 6
    lCmt = 1
    
    For Each cmt In ws.Comments
      Set rngCmt = cmt.Parent
      With rngCmt
        Set shpCmt = ws.Shapes.AddShape(msoShapeRectangle, _
          rngCmt.Offset(0, 1).Left - shpW, .Top, shpW, shpH)
      End With
      With shpCmt
        .Name = "CmtNum" & .Name
        With .Fill
          .ForeColor.SchemeColor = 9 'Цвет заливки
          .Visible = msoTrue
          .Solid
        End With
        With .Line
          .Visible = msoTrue
          .ForeColor.SchemeColor = 64 'Цвет обводки, задаётся автоматически для всех индикаторов!
          .Weight = 0.25 'Толщина обводки, задаётся автоматически для всех индикаторов!
        End With
        With .TextFrame
          .Characters.Text = lCmt
          .Characters.Font.Size = 5 'Размер текста
          .Characters.Font.ColorIndex = xlAutomatic
          .MarginLeft = 0#
          .MarginRight = 0#
          .MarginTop = 0#
          .MarginBottom = 0#
          .HorizontalAlignment = xlCenter 'Расположение текста (в данном случае в центре).
        End With
        .Top = .Top + 0.001 'Расположение рамки (в данном случае справа).
      End With
      lCmt = lCmt + 1
    Next cmt
End Sub

Private Sub NoteZoom3()
    With ActiveWindow.VisibleRange
         NoteChangeSize .Width, .Height, True
    End With
End Sub
 
Private Sub NoteChangeSize(w!, h!, Optional scr As Boolean)
    With ActiveCell.Comment.Shape
         .Width = w: .Height = h
         If scr Then .Top = 0: .Left = 0: .Visible = msoTrue
    End With
End Sub

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

hPtr = GetClipboardData(lPicType)

Private Sub Workbook_Open()
    Application.OnKey "^{n}", CodeName & ".ContextMenu"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnKey "^{n}"
End Sub

Private Sub ContextMenu()
    If ActiveCell Is Nothing Then Exit Sub
    If ActiveCell.Comment Is Nothing Then Exit Sub
    
    On Error Resume Next 'Можно и без оного, но тогда с перебором(циклом) CommandBars.
    Dim cb As CommandBar
    Set cb = Application.CommandBars("vbaPopup")
    If cb Is Nothing Then CreateContextMenu
    
    Application.CommandBars("vbaPopup").ShowPopup
End Sub

Private Sub CreateContextMenu()
    Dim a1_icon, a1_file, a2, a3, i&, m$, p$, f$: m = CodeName & ".": p = Path & "\Image\"
    a1_icon = Array(76, 72, 178, 53)
    a1_file = Array("NoteZoom_200x110.jpg", "NoteZoom_600x400.jpg", "Full Screen.jpg", "NoteZoom_InputBox.jpg", "Copy Text.jpg")
    a2 = Array("NoteZoom 200x110", "NoteZoom 600x400", "Note <Full Screen>", "NoteZoom InputBox", "Скопировать текст примечания")
    a3 = Array("NoteZoom1", "NoteZoom2", "NoteZoom3", "NoteZoom_InputBox", "NoteTextToClipboard")
    
    With Application.CommandBars.Add("vbaPopup", msoBarPopup, , True) 'Можно и НЕ делать контекстное меню временным.
         For i = 0 To UBound(a1_file) 'Ubound(a1_ico)
             With .Controls.Add
                  f = p & a1_file(i)
                  If Len(Dir(f)) Then
                     .Picture = LoadPicture(f)
                  Else
                     .FaceId = a1_icon(i) 'Если файл не найден, то иконка (но это необязательно).
                  End If
                  .Caption = a2(i)
                  .OnAction = m & a3(i)
             End With
         Next
    End With
End Sub

    SavePicture PastePicture(xlBitmap), sBmpPath$