Tom Urtis__Pls have a look here.

[Jaafar Tribak]

Hi,

I used the rather overlooked property ( RangeFromPoint) to find a solution to the problem Highlighting cell under mouse pointer)raised here : http://www.mrexcel.com/board2/viewtopic.php?t=90381&highlight=mouse

...Can't believe I missed this handy property which makes the whole thing so easy.

I have tried the code below and it worked quite nicely for me apart from the mouse flickering which I hope I could get rid of.

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Type POINTAPI
    x As Long
    y As Long
End Type

Dim lngCurPos As POINTAPI
Dim Cancel As Boolean
Dim R As Range
Dim oldColor As Long

Public Sub ChangeCellColor()
    Cancel = False
    On Error Resume Next
        Do Until Cancel = True
            With ActiveWindow
                If Not R Is .RangeFromPoint(lngCurPos.x, lngCurPos.y) Then
                    R.Interior.ColorIndex = oldColor
                End If
                GetCursorPos lngCurPos
                Set R = .RangeFromPoint(lngCurPos.x, lngCurPos.y)
                oldColor = R.Interior.ColorIndex
                .RangeFromPoint(lngCurPos.x, lngCurPos.y).Interior.ColorIndex = 3 'Red
            End With
        DoEvents
        Loop
End Sub

Public Sub CancelProcedure()
    Cancel = True
    Set R = Nothing
End Sub

Hey Tom, is the Beers prize still on ?

Regards.

 

[PaddyD]

neat code, Jaafar, albeit of questionable utility

as well as the 'flicker', it has the following, no doubt unintended, feature:

when you make an entry in a cell while the code is running, the cell gets formatted...

 

[XLGibbs]

That is some pretty cool work...

Interesing that whatever cell the cursor is on will retain the color once you type in that cell or another one.

 

[Jaafar Tribak]

neat code, Jaafar, albeit of questionable utility

as well as the 'flicker', it has the following, no doubt unintended, feature:

when you make an entry in a cell while the code is running, the cell gets formatted...

Hi Paddy,

I know, Not very a useful code but I was interested in it just for the challenge....You are right , editing a cell is problematic. Maybe I should use a Timer instead of a DoEvents inside a loop.

Regards.

 

[Tom Urtis]

jaafar - -

Ha ha...what annoying code that is while running, with all that flickering. I wouldn't use it for my client projects but I sure give you a ton of credit for sticking with the issue.

You not only need to make an entry as Paddy said, but all it would take to change the cell formatting is to double-click the cell, or right-click and run the CancelProcedure macro.

Yes the beer, sourdough, and chocolate offer still stands. Your code is technically not exactly in the spirit of the original link because it comes with the aforementioned baggage, as opposed to the stable behavior you see when mousing over an ActiveX control, but I truly admire your tenacity, and the code sure is, well, unique, and close enough.

Please email me your mailing address and I'll send you in quantity what I promised, which is Anchor Steam beer, Ghirardelli chocolate, and fresh genuine Sourdough bread right from Fisherman's Wharf here in San Francisco.

Same offer applies to anyone over age 21 (beer involved) who can do the essence of jaafar's code without the flickering and byproduct of permanent cell formatting.

Thanks for the code jaafar, and please send me your mailing address. Cool stuff.

 

[Jaafar Tribak]

Hi again,

Warning ! : If you try this code make sure you save any workbooks that you may have open first as it will crash the application.

I have been looking for a different approach that deosn't require a Do Loop code and managed to come up with this code that uses a Windows Hook.

The code looks correct to me however when I set the Hook by running the Hook procedure , the mouse click and keyboard input freeze ! consequently no editing is possible while the hook is set.Eventually I have to press Alt+Ctrl+Del to quit Excel

Pls, Can anybody spot what the problem may be or what I am doing wrong ?

Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Public Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MOUSEHOOK
   pt As POINTAPI
   hWnd As Long
   wHit As Long
   dwExtra As Long
End Type

Public Const WH_MOUSE = 7
Public Const WM_MOUSEMOVE = &H200
Public hHook As Long
Public R As Range

Public Sub Hook()
    Dim lngTreadID, lngModHwnd As Long
    lngTreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
    hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, lngModHwnd, lngTreadID)
End Sub


Public Function MouseProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim MouseParam As MOUSEHOOK
    If idHook >= 0 Then
        If wParam = WM_MOUSEMOVE Then
            CopyMemory MouseParam, ByVal lParam, Len(MouseParam)
            On Error Resume Next
            With ActiveWindow
                If Not R Is .RangeFromPoint(MouseParam.pt.x, MouseParam.pt.y) Then
                    R.Interior.ColorIndex = oldColor
                End If
                GetCursorPos lngCurPos
                Set R = .RangeFromPoint(MouseParam.pt.x, MouseParam.pt.y)
                oldColor = R.Interior.ColorIndex
                .RangeFromPoint(MouseParam.pt.x, MouseParam.pt.y).Interior.ColorIndex = 3 'Red
            End With
        End If
    End If
    MouseProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
End Function

Public Sub Unhook()
    UnhookWindowsHookEx hHook
End Sub

Regards.

 

[Jaafar Tribak]

Hi all,

Here is an improved version of the initial code which eliminates the flickering problem as well as the unwanted formatting of edited cells :

Place this in a Standard module:

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Type POINTAPI
    x As Long
    Y As Long
End Type

Dim lngCurPos As POINTAPI
Dim TimerOn As Boolean
Dim TimerId As Long
Public oldColor As Long
Dim newRange As Range
Dim oldRange As Range
    
    
Sub StartTimer()
    If Not TimerOn Then
        TimerId = SetTimer(0, 0, 0.01, AddressOf TimerProc)
        TimerOn = True
    Else
         MsgBox "Timer already On !", vbInformation
    End If
End Sub


Sub TimerProc()
    On Error Resume Next
    GetCursorPos lngCurPos
    Set newRange = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.Y)
    If newRange.Address <> oldRange.Address Then
        oldRange.Interior.ColorIndex = oldColor
        Set oldRange = newRange
        oldColor = newRange.Interior.ColorIndex
        newRange.Interior.ColorIndex = 3
    End If
End Sub


Sub StopTimer()
    If TimerOn Then
        KillTimer 0, TimerId
        TimerOn = False
    Else
        MsgBox "Timer already Off", vbInformation
    End If
End Sub

Place this in the Worksheet module :

Dim TrgtColor As Long
Dim oldTarget As Range

Private Sub Worksheet_Change(ByVal Target As Range)
    Target.Interior.ColorIndex = TrgtColor
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set oldTarget = Target
    TrgtColor = oldColor
End Sub

Now run the StartTimer Sub and move the mouse around.
To stop this , run the StopTimer Sub.


I have tested this and the only remaining problem now is if you edit a cell and move the Mouse simultaneously,the cell under the cursor may sometimes get formatted but this is an unlikely scenario.

Regards.

 

[Tom Urtis]

Very nice Jaafar, thanks for following up. In many cases with no cells on the sheet being shaded originally, this codeline when placed immediately above the Else statement in the StopTimer macro would negate the lingering color format in the last "hovered over" cell when the timer is stopped:

Cells.Interior.ColorIndex = 0

Nice work, thanks again.

 

[Jaafar Tribak]

Very nice Jaafar, thanks for following up. In many cases with no cells on the sheet being shaded originally, this codeline when placed immediately above the Else statement in the StopTimer macro would negate the lingering color format in the last "hovered over" cell when the timer is stopped:

Cells.Interior.ColorIndex = 0

Nice work, thanks again.

Thanks for the feedback Tom

Regards.

 

[Jaafar Tribak]

Hi again,

I hate the title I gave this thread..It sounds so sloppy


This is yet an other improvement on the previous code(s) in that now, the selected Cells don't get easily Formatted even when Double Clicked as opposed to when using the Timer approach...( noticed some inconsistency if I move the Mouse very fast !)

I have installed a thread specific Mouse Hook to do the Job which I think is also cleaner than using a Timer.

I was inspired to use this extremely useful Hooking technic when I found the solution for Locking the KeyBoard look here : http://www.mrexcel.com/board2/viewtopic.php?t=161559&start=10

Same Concept could be applied to many other scenarios.

Place the Code in a Standard Module , add two Buttons to the Worksheet, assign procedure Hook_Mouse to the First Button and UnHook_Mouse to the Second Button.

Option Explicit

Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEMOVE = &H200

Dim hhkLowLevelMouse, lngInitialColor As Long
Dim blnHookEnabled As Boolean
Dim udtCursorPos As POINTAPI
Dim objCell As Variant



Public Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    ' Prevent error if objCell is Nothing
    On Error Resume Next
    
    With objCell
    
        'Reset initial color
        .Interior.ColorIndex = lngInitialColor
        
        ' Apply this to  'Sheet1'  Only... Change as required
        If ActiveSheet.Name = "Sheet1" Then
        
            If (nCode = HC_ACTION) Then
            
                ' when Mouse is moved, highlight cell and allow Mouse Movement
                If wParam = WM_MOUSEMOVE Then
                
                   'Process WM_MOUSEMOVE message first
                    LowLevelMouseProc = False
                    
                    ' Get Mouse Pointer location & Highlight Cell underneath
                    GetCursorPos udtCursorPos
                    Set objCell = ActiveWindow.RangeFromPoint(udtCursorPos.x, udtCursorPos.Y)
                    
                    'Store Initial cell color
                    lngInitialColor = .Interior.ColorIndex
                    
                    'Change Color of Cell under Mouse pointer
                    .Interior.ColorIndex = 6
                End If
                
                Exit Function
            
            End If
            
        End If
    
    End With
    
    LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
    
End Function


 Sub Hook_Mouse()
 
    'Prevent Hooking more than once
    If blnHookEnabled = False Then
    
       hhkLowLevelMouse = SetWindowsHookEx _
       (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
       blnHookEnabled = True
       
    End If
    
End Sub


 Sub UnHook_Mouse()
 
    If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
    'reset Flag
    blnHookEnabled = False
    
End Sub

Regards.