Macro to Double click on Note to Select E4

[howard]

i have a note pertaining to E4. I have tried to write code so that if I double click the note that the cursor will go to cell E4

When clicking on the note , nothing happens


It would be appreciated if someone could amend my code

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rng As Range
    Dim noteRange As Range
    
    Set rng = Me.Cells.SpecialCells(xlCellTypeComments) ' Get all cells with notes
    
    If rng.Cells.Count > 0 Then
        For Each noteRange In rng
            If Not noteRange.Comment Is Nothing Then
                If Not Intersect(Target, noteRange.Comment.Shape.TopLeftCell) Is Nothing Then
                    Application.Goto Me.Range("E4") ' Go to the specified cell (E4)
                    Exit Sub
                End If
            End If
        Next noteRange
    End If
End Sub [code]

 

[Jaafar Tribak]

Sorry. I am not quite understanding. How many notes(comments) do you have on the worksheet ? Is it Just one comment attached to cell E4?
And when you say *double click the note*, do you mean double clciking inside the actual comment or double clicking on the cell that has the comment attached to it ?

 

[howard]

I have one note (comment) that if for E4 , but the note is several cells below with an arrow showing it relates to cell E4. I need to double click on the comment to select E4

 

[Jaafar Tribak]

I have one note (comment) that if for E4 , but the note is several cells below with an arrow showing it relates to cell E4. I need to double click on the comment to select E4

Excel doesn't provide a double-click event nor any other events for cell comments... I can't think of any workaround except perhaps using a Win32 API hack which would be hacky at best.

 

[howard]

Thanks for letting me know

 

[Jaafar Tribak]

Is it ok for you to run the macro when right-clicking the comment instead of when double-clicking it?
So, when you right-click the comment, a small popup menu is shown, clicking on which will jump the selection to the related cell.

If that's ok , I can post some code.

 

[howard]

That will be perfect. Kindly provide code to do this

 

[Jaafar Tribak]

Ok- This code uses a Win32 timer to monitor when the comment is being selected. Once the comment is selected, the code displays a context popup menu, clicking on which, a predesignated Macro is executed.

This works even when the Cell housing the comment is completely offscreen.

Drawbacks:
1- Uses a timer. This has an impact on performace.
2- As is, the code works only on 1 comment at a time.

Download:
CommentEvent.xlsm





1- Code in a Standard Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

#If VBA7 Then

#If Win64 Then
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    #Else
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As LongPtr, ByVal hBitmapChecked As LongPtr) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private oRange As Range, oComment As Comment, sMacroName As String


Public Sub HookComment( _
    ByVal Comment As Comment, _
    ByVal MacroName As String, _
    ByVal bHook As Boolean _
)
    If bHook Then
        Set oRange = Comment.Parent
        Set oComment = Comment
        sMacroName = MacroName
        Call HideCommentMenu(True)
        Call SetHooks(True)
    Else
        Call HideCommentMenu(False)
        Call SetHooks(False)
    End If
End Sub

Private Sub SetHooks(ByVal bHook As Boolean)
    If bHook Then
        Call KillTimer(Application.hwnd, NULL_PTR)
        Call SetTimer(Application.hwnd, NULL_PTR, 0&, AddressOf TimerProc)
    Else
        Call KillTimer(Application.hwnd, NULL_PTR)
    End If
End Sub

Private Sub HideCommentMenu(ByVal bHide As Boolean)
    Application.CommandBars("Shapes").Enabled = Not bHide
End Sub

Private Sub TimerProc()

    Dim tCommentRect As RECT
    Dim tCurPos As POINTAPI
    Dim oObj As Object
    Dim hParent As LongPtr
    Dim lRet As Long
   
    On Error Resume Next
   
    hParent = FindWindowEx(FindWindowEx(Application.hwnd, NULL_PTR, "XLDESK", vbNullString), _
              NULL_PTR, "EXCEL7", vbNullString)
   
    Call GetCursorPos(tCurPos)
    tCommentRect = GetObjRect(oComment.Shape)
   
    #If Win64 Then
        Dim lPtr As LongLong
        Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
        lRet = PtInRect(tCommentRect, lPtr)
    #Else
        lRet = PtInRect(tCommentRect, tCurPos.X, tCurPos.Y)
    #End If

    If lRet Then
        Call HideCommentMenu(True)
        If Selection.Name = oComment.Shape.Name Then
            If GetAsyncKeyState(VBA.vbKeyRButton) Then
                Call CreateAndShowRightClickMenu
            End If
        End If
    Else
        Call HideCommentMenu(False)
    End If

End Sub

Private Sub CreateAndShowRightClickMenu()

    Const TPM_RETURNCMD = &H100&, MF_STRING = &H0&, MF_BYPOSITION = &H400
    Dim tCursorPos As POINTAPI
    Dim oStdPic As stdole.StdPicture
    Dim hwnd As LongPtr, hMenu As LongPtr
    Dim lShowPopupMenu As Long

    hwnd = FindWindowEx(FindWindowEx(Application.hwnd, NULL_PTR, "XLDESK", vbNullString), _
           NULL_PTR, "EXCEL7", vbNullString)
 
    hMenu = CreatePopupMenu()
    Call AppendMenu(hMenu, MF_STRING, 1, "Goto Parent Cell")
    Set oStdPic = Application.CommandBars.FindControl(ID:=3181&).Picture
    Call SetMenuItemBitmaps(hMenu, 0&, MF_BYPOSITION, oStdPic, oStdPic)
   
    Call GetCursorPos(tCursorPos)
    lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.X, tCursorPos.Y, hwnd, ByVal 0&)
    If lShowPopupMenu = 1 Then
        Application.Run sMacroName, oRange.Address
    End If
    Call DestroyMenu(hMenu)
   
End Sub

Private Function GetObjRect(ByVal obj As Object) As RECT
    Dim oPane  As Pane
    Set oPane = ThisWorkbook.Windows(1&).ActivePane

    With GetObjRect
        .Left = oPane.PointsToScreenPixelsX(obj.Left - 1&)
        .Top = oPane.PointsToScreenPixelsY(obj.Top)
        .Right = oPane.PointsToScreenPixelsX(obj.Left + obj.Width)
        .Bottom = oPane.PointsToScreenPixelsY(obj.Top + obj.Height)
    End With
End Function

Private Sub Auto_Close()
    Call HideCommentMenu(False)
    Call SetHooks(False)
End Sub

2- Code Usage test

Option Explicit

Sub Start()
    HookComment Comment:=Sheet1.Range("B10").Comment, MacroName:="MyMacro", bHook:=True
End Sub

Sub Finish()
    HookComment Comment:=Sheet1.Range("B10").Comment, MacroName:="MyMacro", bHook:=False
End Sub

Sub MyMacro(ByVal RangeAddr As String)
    Range(RangeAddr).Activate
End Sub

 

[howard]

Many thanks for the help.

 

[Jaafar Tribak]

Many thanks for the help.

You are welcome.

BTW, if you like to quickly go the opposite way (ie:= from the cell back to the comment) to gain time , you can simply use the sheet Double-click or the Sheet Right-Click events as follows

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = Range("B10").Address Then
        Cancel = True
        Application.Goto Target.Comment.Shape.TopLeftCell
    End If
End Sub