Dynamically highlight the cell under the Mouse Pointer !

[RAFAAJ2000]

The code I am using here does highlight the cell under the cursor ( Without
selecting the cell) but has two major problems :

1- It causes too much flickering .

2- If a cell is selected with the Mouse, the selected cell is sometimes
Formatted which shouldn't normally happen .


Here is the code:

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
Dim oldColor As Long
Dim R As Range

Sub StartTimer()
If Not TimerOn Then
TimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
TimerOn = True
Else
MsgBox "Timer already On !", vbInformation
End If
End Sub


Sub TimerProc()
On Error Resume Next
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
End Sub

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


I hope someone can improve this code by fixing the 2 mentioned problems or
maybe just offer a new solution altogether.

Thanks.

Jaafar.

 

[K Dales]

The flickering is due to the delay caused by time it takes to run the code,
especially in comparison to a short timer interval. I thought of a couple
things to optimize the code somewhat in TimerProc (You can eliminate the
With... End With, since you only use ActiveWindow once inside this loop; you
can calculate .RangeFromPoint only once and assign that to another variable,
you can eliminate the DoEvents here since you end the Sub right after it, and
you can increase the timer interval a bit - one millisecond is much faster
than the user can respond) - but while these could make a bit of improvement
in the flickering nothing made it go away - and it seems that it is when the
mouse moves to a new cell while the code is running, that is when the
formatting gets messed up since the active cell changes before you can reset
the format. In the end, after testing it and seeing where the delay is
coming from, I believe it is caused by the call to GetCursorPos; and since
that is a library routine there is nothing you can do to change that.
Without the cursor position you can't highlight the cell, though, and I know
of no easier or quicker way to find it than what you are doing here. So
maybe I have helped define the problem a bit more, but afraid I can't offer a
solution!

 

[Vic Eldridge]

Hi Jaafar,

I added a couple of module-level variables,

Dim newRange As Range
Dim oldRange As Range

and changed your TimerProc to this,

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


The flickering is gone because now it changes the backcolor only when needed.
Selecting a cell no longer shows any side-effects, however editing a cell
causes it to retain the new formatting. Perhaps you could avoid this by using
sheet protection, or fix it via the Worksheet_Change event.
Worksheet_BeforeDoubleClick might come in handy too.


Regards,
Vic Eldridge

 

[RAFAAJ2000]

Nice touche Vic,

I have added some code in the Worksheet class module to prevent the unwanted
formatting of the cells when editing the sheet.

The code now looks as follows :

' Placed 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


This bit goes in a 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


Again thanks for your help.

Jaafar.