Message display above cursor when hover over cell

[palaeontology]

I've read a number of posts on messages being displayed when hovering above a cell, but none of them (as far as I have read) displayed the message how and where I'd like it.

I have 12 worksheets that all look similar to the image below ...

Each worksheet receives data from a cross country running race, and as there can be up to four races on the course at the same time, runners from those four races can be crossing the finishing line roughly at the same time, which requires me to be flicking between the worksheets and entering data within seconds of eachother.

Though I have the name of the teams which the athletes belong to in row 2 (immediately above a 'Freeze' line), when flicking quickly between sheets, having to look up even those few inches puts me behind time and I run the risk of missing finishers crossing the line.

So ... is there a way I can have the name of the team appear IMMEDIATELY above the cursor as it spans across the columns when I'm trying to find the relevant cell to enter a number ?

For example, if I wanted to place a value into cell L67, the name of the team that belongs to column L ... in this case Chisholm ... would appear immediately above the cursor (see the mockup diagram below).

and as I move the cursor across columns, the name of the team that belongs to those columns would appear. For example as I span the cursor from column R to N, the names Sutherland, then Mitchell, then Leichhardt, then Laver, then Gould would appear in the 'hover message box' above the cursor.

This would help me enormously.

Is it possible ?

Very kind regards,

Chris

 

[Jaafar Tribak]

If speed is what you need first and foremost, then you would probably need to use a windows timer to quickly render the text on the screen... That said, using a timer can result in a performance hit, particularly if you simultaneously have other workbooks opened.

 

[Jaafar Tribak]

I gave this a shot on a mock-up workbook over the weekend and came up with this :

The arguments in the ShowCellHoverMessage routine should be self-explanatory.

I hope it works for you.

Download:
MsgOnMouseHover.xlsm






1- Code in a Standard Module:

Option Explicit

Public Enum MSG_ALIGNMENT
    Horz
    Ver
End Enum

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

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As LongPtr, lpMetrics As TEXTMETRIC) As Long
    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 CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    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 LongPtr
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long, ByVal lpString As LongPtr, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) 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 Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As LongPtr, ByVal lpClassName As LongPtr, ByVal nMaxCount As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As LongPtr, lpMetrics As TEXTMETRIC) 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 CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    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 LongPtr
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal lpString As LongPtr, ByVal nCount As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) 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 Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Any, ByVal bErase As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As LongPtr, ByVal lpClassName As LongPtr, ByVal nMaxCount As Long) As Long
#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

Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFist4Byes As Long
    tmSecond4Byes As Long
    tmCharSet As Byte
End Type

Const LF_FACESIZE = 32&
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type MsgAttributes
    TargetRange As Object
    Msg As String
    Alignment As MSG_ALIGNMENT
    TextColor As Long
    FontSize As Long
    ClearBKColor As Boolean
End Type

Private tMsgAttr As MsgAttributes
Private hParent As LongPtr
Private hStatic As LongPtr
Private hDC As LongPtr


Public Sub Start()

    Const WS_CHILD = &H40000000, WS_VISIBLE = &H10000000, WS_DISABLED = &H8000000
    Const WS_BORDER = &H800000, CW_USEDEFAULT = &H80000000
    Const TRANSPARENT = 1&

    If IsWindow(GetMsgWindow) Then Exit Sub
    
    Call KillTimer(GetMsgWindow, NULL_PTR)
    hParent = Application.hwnd
    hStatic = NULL_PTR
    hStatic = CreateWindowEx( _
                0&, StrPtr("EDIT"), StrPtr(Chr(10&)), _
                WS_CHILD + WS_VISIBLE + WS_DISABLED + WS_BORDER, _
                CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, hParent, NULL_PTR, _
                GetModuleHandle(StrPtr(vbNullString)), ByVal 0& _
              )
    hDC = GetDC(hStatic)
    Call SetBkMode(hDC, TRANSPARENT)
    Call SetTimer(GetMsgWindow, NULL_PTR, 0&, AddressOf Timerproc)

End Sub


Public Sub Finish()
    Call KillTimer(GetMsgWindow, NULL_PTR)
    Call ReleaseDC(GetMsgWindow, hDC)
    Call DestroyWindow(GetMsgWindow)
End Sub


Public Sub ShowCellHoverMessage( _
    ByVal Msg As String, _
    Optional ByVal TargetRange As Object, _
    Optional ByVal Alignment As MSG_ALIGNMENT = Horz, _
    Optional ByVal TextColor As Long = -1, _
    Optional ByVal FontSize As Long = -1, _
    Optional ClearBKColor As Boolean _
)

    With tMsgAttr
        If TargetRange Is Nothing Then Set TargetRange = ActiveSheet.Cells
        Set .TargetRange = TargetRange
        .Msg = Msg
        .Alignment = Alignment
        .TextColor = IIf(TextColor = -1&, 0&, TextColor)
        .FontSize = IIf(FontSize = -1&, 18&, FontSize)
        If ClearBKColor Then
            If IsWindowEnabled(GetMsgWindow) = False Then
                Call EnableWindow(GetMsgWindow, True)
            End If
        End If
    End With

End Sub



' ________________________________________ Private Routines ____________________________________________________

Private Function GetMsgWindow() As LongPtr
    GetMsgWindow = FindWindowEx(Application.hwnd, NULL_PTR, vbNullString, Chr(10&))
End Function

Private Sub Timerproc()

    Const DT_CALCRECT = &H400, DT_WORDBREAK = &H10, DT_NOCLIP = &H100, DT_VCENTER = &H4
    Const SWP_NOACTIVATE = &H10, SWP_SHOWWINDOW = &H40
    Const ANTIALIASED_QUALITY = 4&
    Const LOGPIXELSY = 90&
    
    Static tPrevCursPos As POINTAPI
    Static tCursPos As POINTAPI
    Static oPrevObjFromPt As Object
    
    Dim tParentRect As RECT, tTextRect As RECT
    Dim tTopLeftPos As POINTAPI, tClientCursPos As POINTAPI
    Dim tm As TEXTMETRIC
    Dim tFont As LOGFONT
    Dim hPrevFont As LongPtr, hFont As LongPtr
    Dim arFaceName() As Byte
    Dim hWinFromPt As LongPtr
    Dim sBuff As String, lRet As Long
    Dim oObjFromPt As Object
    Dim sTmpArray() As String, sCumulText As String
    Dim lTextWidth As Long, i As Long

    On Error Resume Next
    
    Call GetCursorPos(tClientCursPos)
    #If Win64 Then
        Dim Ptr As LongLong
        Call CopyMemory(Ptr, tClientCursPos, LenB(tClientCursPos))
        hWinFromPt = WindowFromPoint(Ptr)
    #Else
        hWinFromPt = WindowFromPoint(tClientCursPos.x, tClientCursPos.Y)
    #End If
    sBuff = String(256&, vbNullChar)
    lRet = GetClassName(hWinFromPt, StrPtr(sBuff), 256&)
    If Left(sBuff, lRet) <> "EXCEL7" Then
        Call ShowWindow(hStatic, 0&): GoTo Xit
    End If
    
    Set oObjFromPt = ActiveWindow.RangeFromPoint(tClientCursPos.x, tClientCursPos.Y)

    If oObjFromPt.Address <> oPrevObjFromPt.Address Then
        Call InvalidateRect(hStatic, ByVal 0&, 0&): GoTo Xit
    End If

    Call ThisWorkbook.OnCellHover(oObjFromPt)
    
    If Len(tMsgAttr.Msg) = 0& Or TypeName(oObjFromPt) <> "Range" Or Not (ThisWorkbook Is ActiveWorkbook) Then
        Call ShowWindow(hStatic, 0&): GoTo Xit
    End If
    
    If Intersect(tMsgAttr.TargetRange, oObjFromPt) Is Nothing Then
        Call ShowWindow(hStatic, 0&): GoTo Xit
    End If
    
    With tMsgAttr
        If .Alignment = Horz Then
            .Msg = Replace(.Msg, Chr(10&), "  " & Chr(10&) & "  ")
        End If
        .Msg = "  " & .Msg & "  "
        Call SetTextColor(hDC, .TextColor)
    End With
    
    arFaceName = StrConv("Calibri" & vbNullChar, vbFromUnicode)
    With tFont
        .lfHeight = -MulDiv(tMsgAttr.FontSize, GetDeviceCaps(hDC, LOGPIXELSY), 72&)
        .lfEscapement = IIf(tMsgAttr.Alignment = Horz, 0&, 900&)
        .lfQuality = ANTIALIASED_QUALITY
        Call CopyMemory(.lfFaceName(0&), arFaceName(0&), UBound(arFaceName))
    End With
    hFont = CreateFontIndirect(tFont)
    hPrevFont = SelectObject(hDC, hFont)
      
    Call GetTextMetrics(hDC, tm)
      
    If tMsgAttr.Alignment = Ver Then
        sTmpArray = Split(tMsgAttr.Msg, Chr(10&))
        For i = LBound(sTmpArray) To UBound(sTmpArray)
            Call DrawText(hDC, StrPtr(sTmpArray(i) & " "), -1&, tTextRect, DT_CALCRECT)
            lTextWidth = lTextWidth + (tTextRect.Right - tTextRect.Left)
            sCumulText = sCumulText & sTmpArray(i) & " "
        Next i
        Erase sTmpArray
    Else
        Call DrawText(hDC, StrPtr(tMsgAttr.Msg), -1&, tTextRect, DT_CALCRECT)
    End If

    Call ScreenToClient(hParent, tTopLeftPos)
    Call ScreenToClient(hParent, tClientCursPos)

    With tTextRect
        If tMsgAttr.Alignment = Ver Then
            tTopLeftPos.x = tClientCursPos.x - (tm.tmHeight + 8&) / 2&: tTopLeftPos.Y = tClientCursPos.Y
            Call SetWindowPos( _
                    hStatic, NULL_PTR, tTopLeftPos.x, tTopLeftPos.Y - (lTextWidth) - 20&, _
                    tm.tmHeight + 8&, lTextWidth, SWP_NOACTIVATE + SWP_SHOWWINDOW _
                 )
            Call TextOut(hDC, 2&, lTextWidth, StrPtr(sCumulText), Len(sCumulText))
        Else
            tTopLeftPos.x = tClientCursPos.x + 20&: tTopLeftPos.Y = tClientCursPos.Y - (.Bottom - .Top) - 20&
            Call GetClientRect(hParent, tParentRect)
            If tTopLeftPos.x + (.Right - .Left) >= tParentRect.Right Then
                tTopLeftPos.x = tTopLeftPos.x - (.Right - .Left) - 40&
            End If
            Call SetWindowPos( _
                    hStatic, NULL_PTR, tTopLeftPos.x, tTopLeftPos.Y, _
                    (.Right - .Left), .Bottom - .Top, SWP_NOACTIVATE + SWP_SHOWWINDOW _
                 )
            Call DrawText(hDC, StrPtr(tMsgAttr.Msg), -1&, tTextRect, DT_VCENTER + DT_WORDBREAK + DT_NOCLIP)
        End If
    End With

Xit:
    Call SelectObject(hDC, hPrevFont)
    Call DeleteObject(hFont)
    Call GetCursorPos(tCursPos)
    Set oPrevObjFromPt = ActiveWindow.RangeFromPoint(tCursPos.x, tCursPos.Y)
    tPrevCursPos = tCursPos

End Sub

Private Sub Auto_Close()
    Call Finish
End Sub

2- Code Usage in the ThisWorkbook Module:

Option Explicit

Public Sub OnCellHover(ByVal Cell As Range)

    Dim eAlignment As MSG_ALIGNMENT
    
    eAlignment = IIf(Sheet1.CheckBox1.Value, Ver, Horz)
    
    Call ShowCellHoverMessage( _
        Msg:=Sheet1.Cells(5&, Cell.Column).Text, _
        TargetRange:=Sheet1.Range("B6:Q100"), _
        Alignment:=eAlignment, _
        TextColor:=vbRed, _
        FontSize:=-1&, _
        ClearBKColor:=False _
     )

End Sub

The OnCellHover pseudo-event must always be declared PUBLIC and must always reside in the ThisWorkbook Module so it can be seen by the timer callback .

 

[palaeontology]

Thankyou so much.

That works extremely well.

My laptop is probably a little under-powered, as it's showing 'mouse-drag echoes' but I do believe that's my laptop power issues, and not your code.

Thankyou, again, so much.

Very kind regards,

Chris