While mouse cursor on top of A1 cell

[Erdinç E. Karaçam]

Hi everyone,

I would like to change A1 cell's Interior.ColorIndex to red color and A1's font format to Italic, while mouse cursor on top of A1 cell.

Can i do it with a VBA code or any different way to do it?

Thanks a lot.


For a funny example:

Sub CursorOnA1() 
    If MouseCursor OnTopOf [A1] Then 
        With [A1] 
            .Interior.ColorIndex = 3 
            .Font.Italic = True 
        End If 
    End If 
End Sub

 

[Erdinç E. Karaçam]

On my machine, CPU 6% - 24%

Hi Jaafar, Class is very good, congratilations.

 

[jaleahmad]

Unfortunately I couldn't see anything (cell formatting) happening even when I hoover the mouse pointer on A1.

FYI, what I did:
1. copy the code in Module1
2. copy the class (named ClsWorkSheet_MouseMoveEvent) code in a new class
3. insert in ThisWorkBook thios code to run "CretaeMouseMoveEvent":

Private Sub Workbook_Open()
'StartTimer
CreateMouseMoveEvent
MsgBox """CreateMouseMoveEvent"" is running..."

End Sub

Could you help me?

Hi all,

I've always wanted to encapsulate the main backbone code in a Class and to also encapsulate the actual calling custom event code in a format that is more instinctive to the user ( something like : Worksheet_MouseMove(ByVal oCellTarget As Range, ByVal lX As Long, ByVal lY As Long...).
Not only would this be more instinctive but would also give more control, flexibility and autonomy to the developper as the event code is now kept seperate from the main.

Using a timer has a bad impact on performance so I have decided to set it up in a different XL instance that is created dinamically within the Class. Although this Does a litle bit improve performance, it poses a problem as the VBE has to be used therefore the Macro Security settings have to be lowered in order for it to work.

Ideally, I would have used VBScript for this but it doesn't support API declartions !

Anyway, thanks to encapsulating this in a Class and thanks to the Callback\Mouse Event handler all there is to do now is create an instance of the Class, set its Properties as shown below and run it. The Class will only run whatever YOU ,the programmer, decide to put in its Callback routine.


Demo Download : http://www.savefile.com/files/129127
Note: Save the download to disk otherwise it may not work !

Here is an example- Put this in a Standard Module and run the CreateMouseMoveEvent Routine :

Option Explicit
 
Dim MyClassTest As ClsWorkSheet_MouseMoveEvent
Dim sMsg As String
 
 
'\\RUN THIS PROCEDURE ******************************
 
Sub CreateMouseMoveEvent()
 
    '\\declare & set the Class properties
    Set MyClassTest = New ClsWorkSheet_MouseMoveEvent
    With MyClassTest
        .CallBackProcedure = "Worksheet_MouseMove"
        .WorkSheetName = Worksheets(1).Name
        .Execute
    End With
 
End Sub
 
 
'\\*****very important*********
'\\the name of this callback routine has to match exactly
'\\the string passed to the above 'CallBackProcedure' class property !
'\\also exactly 3 arguments are to be passed to the callback and must be passed Byval
'\\error handling should be imlemented to avoid potential crashes !
'\\-----------------------------------------------------------------------------
'\\in this example, the callback which looks like a standard MS event procedure
'\\simply dinamically changes some formatting of the current cell
'\\(which is passed in its first arguments)located under the cursor
 
'\\THIS CALLBACK\EVENT PROC IS THERE FOR THE PROGRAMMER TO WRITE ANY CODE HE\SHE WANTS
 
Sub Worksheet_MouseMove(ByVal oCellTarget As Range, ByVal lX As Long, ByVal lY As Long)
 
    Static lOldColor As Long
    Static lOldTextColor As Long
    Static lOldFontSize As Long
    Static bOldFontBold As Boolean
    Static sOldFormula As String
    Static oOldRange As Range
 
    '\\avoid crashing the app if 'oCellTarget' is Nothing
    On Error Resume Next   '\\ Very important !!!!!
 
    '\\if the class is terminated, restore old values and get out
    If Not MyClassTest.IsMouseEventEnabled Then
        Range("A1").ClearContents
        With oOldRange
            .Interior.ColorIndex = lOldColor
            .Font.ColorIndex = lOldTextColor
            .Font.Size = lOldFontSize
            .Font.Bold = bOldFontBold
            .Formula = sOldFormula
        End With
        Exit Sub
    End If
 
    If oCellTarget.Address <> oOldRange.Address Then
 
        With oOldRange
            .Interior.ColorIndex = lOldColor
            .Font.ColorIndex = lOldTextColor
            .Font.Size = lOldFontSize
            .Font.Bold = bOldFontBold
            .Formula = sOldFormula
        End With
 
        Set oOldRange = oCellTarget
 
        With oCellTarget
            lOldColor = .Interior.ColorIndex
            lOldTextColor = .Font.ColorIndex
            lOldFontSize = .Font.Size
            bOldFontBold = .Font.Bold
            sOldFormula = .Formula
            .Interior.ColorIndex = 3
            .Font.ColorIndex = 6
            .Font.Size = 10
            .Font.Bold = True
        End With
 
        If Len(sOldFormula) = 0 Then
            oCellTarget.Formula = "Empty Cell !!!"
        End If
 
    End If
 
    sMsg = "Current Cell :" & oCellTarget.Address
    Range("A1") = sMsg
 
End Sub
 
 
Sub KillMouseMoveEvent()
 
    On Error Resume Next
    MyClassTest.Disable
 
End Sub

..and here is the Class Code :

Option Explicit
 
'\\Class that simulates a mouse move event
'\\for worksheet cells.
'\\in order to minimise the timer effect on
'\\performance,the class opens a new excel
'\\instance dinamically and runs the timer code from it.
'\\a callback like procedure is also used
'\\to run any custome routine designed by the user.
'\\this callback signature simulates that of other known MS events
'\\xtra care must be taken when editing the callback routine
'\\any mistakes will potentially crash the app !
'\\error handling is therefore vital
'\\Note: this code uses the VBE so it requires that the Macro
'\\Security "Trusted Sources" be enabled.
 
Private sCode As String
Private oNewXLapp As Excel.Application
Private oNewWbk As Workbook
Private Const vbext_ct_StdModule As Long = 1
Private sSheetName As String
Private sCallBackProc As String
Private bMouseEventEnabled As Boolean
Private sMsg As String
 
Public WithEvents WbEvent As Workbook
 
 
Public Sub Execute()
 
    '\\do not open more than one XL instance
    '\\or you will end up with numerous conflicting timers !
    If Not Me.IsMouseEventEnabled Then
 
        '\\assign this workbook to WbEvent prop
        '\\to close the the new XL instance if the user closes
        '\\the workbook before terminating the Class !
        Set Me.WbEvent = ThisWorkbook
 
        '\\set this boolean property\flag
        Me.IsMouseEventEnabled = True
 
        '\\store the timer code in a string
        sCode = "Declare Function SetTimer Lib ""user32"""
        sCode = sCode & "(ByVal hwnd As Long, ByVal nIDEvent As Long,"
        sCode = sCode & "ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Declare Function KillTimer Lib ""user32"""
        sCode = sCode & "(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Declare Function GetTickCount Lib ""kernel32"""
        sCode = sCode & "Alias ""GetTickCount"" () As Long" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Declare Function GetCursorPos Lib ""user32"""
        sCode = sCode & "(lpPoint As POINTAPI) As Long" & vbCrLf
        sCode = sCode & "" & vbCrLf
        sCode = sCode & "Type POINTAPI" & vbCrLf
        sCode = sCode & "   x as Long" & vbCrLf
        sCode = sCode & "   y as Long" & vbCrLf
        sCode = sCode & "End Type" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Dim lCurPos As POINTAPI" & vbCrLf
        sCode = sCode & "Dim bTimerOn As Boolean" & vbCrLf
        sCode = sCode & "Dim lTimerId As Long" & vbCrLf
        sCode = sCode & "Dim lHwnd As Long" & vbCrLf
        sCode = sCode & "Dim oNewRange As Range" & vbCrLf
        sCode = sCode & "Dim oWB As WorkBook" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Sub StartTimer()" & vbCrLf
        sCode = sCode & "  Set oWB = GetObject(" & Chr(34)
        sCode = sCode & ThisWorkbook.FullName & Chr(34) & ")" & vbCrLf
        sCode = sCode & "   If Not bTimerOn Then" & vbCrLf
        sCode = sCode & "        lTimerId = SetTimer"
        sCode = sCode & "(0, 0 , 10, AddressOf TimerProc)" & vbCrLf
        sCode = sCode & "        bTimerOn = True" & vbCrLf
        sCode = sCode & "   End If" & vbCrLf
        sCode = sCode & "End Sub" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        sCode = sCode & "Sub TimerProc()" & vbCrLf
        sCode = sCode & "   On Error Resume Next" & vbCrLf
        sCode = sCode & "   GetCursorPos lCurPos" & vbCrLf
        sCode = sCode & "   Set oNewRange = oWb.Parent.ActiveWindow.RangeFromPoint"
        sCode = sCode & "(lCurPos.x, lCurPos.Y)" & vbCrLf
 
        '\\run procedure on one worksheet only
        sCode = sCode & "If oWb.ActiveSheet.Name = " & Chr(34)
        sCode = sCode & sSheetName & Chr(34) & " Then" & vbCrLf
 
        '\\ensure mouse is pointing to a cell to avoid an error in callback
         sCode = sCode & "If TypeName(oNewRange)=""Range"" Then " & vbCrLf
 
        '\\run the callback from here !!
        sCode = sCode & "oWb.Parent.Run oWb.Name & " & Chr(34) & "!"
        sCode = sCode & sCallBackProc & Chr(34)
        sCode = sCode & ",oNewRange, lCurPos.x, lCurPos.Y" & vbCrLf
        sCode = sCode & "   End If" & vbCrLf
        sCode = sCode & "   End If" & vbCrLf
        sCode = sCode & "End Sub" & vbCrLf
        sCode = sCode & "" & vbCrLf
 
        '\\without this, the timer would not stop !
        sCode = sCode & "Sub StopTimer()" & vbCrLf
        sCode = sCode & "   If bTimerOn Then" & vbCrLf
        sCode = sCode & "        KillTimer 0, lTimerId" & vbCrLf
        sCode = sCode & "        bTimerOn = False" & vbCrLf
        sCode = sCode & "   End If" & vbCrLf
        sCode = sCode & "End Sub" & vbCrLf
 
        '\\now, open a new invisible XL app and place the
        '\\the contents of the string into a new module
        '\\ideally,this would have been done via a VB script
        '\\but VBS do not support API declarations
        '\\
        Set oNewXLapp = CreateObject("Excel.Application")
        Set oNewWbk = oNewXLapp.Workbooks.Add
 
        '\handle error if access to the VBE is NOT trusted
        On Error Resume Next
 
        oNewWbk.VBProject.VBComponents.Add _
        (vbext_ct_StdModule).CodeModule.AddFromString sCode
 
        If InStr(1, Err.Description, "not trusted", vbTextCompare) <> 0 Then
 
            sMsg = "To use this 'MouseMoveEvent Class' "
            sMsg = sMsg & "you must tick " & vbCrLf
            sMsg = sMsg & "the 'Trust Access to Visual Basic Project' CheckBox " & vbCrLf
            sMsg = sMsg & "via Tools\Macro\Security\Trusted Sources TAB, " & vbCrLf
            sMsg = sMsg & "close Excel and reopen it again to take effect."
 
            MsgBox Err.Description & vbCrLf _
            & vbCrLf & sMsg, vbExclamation
 
            With oNewXLapp
            .DisplayAlerts = False
            .Quit
            End With
            End
        Else
            '\\run the code to start the timer from the newly created wbk
            oNewXLapp.Run oNewWbk.Name & "!StartTimer"
        End If
     End If
 
End Sub
 
Public Sub Disable()
 
    On Error Resume Next
 
    If Me.IsMouseEventEnabled Then
        Me.IsMouseEventEnabled = False
 
        '\\here,we run the StopTimer routine located
        '\\ in the invisible XL instance
        oNewXLapp.Run oNewWbk.Name & "!StopTimer"
 
        '\\cleanup
        With oNewXLapp
        .DisplayAlerts = False
        .Quit
        End With
        Set oNewXLapp = Nothing
        Set oNewWbk = Nothing
 
        '\\run the callback one more final time to ensure that all the old
        '\\cell settings are restored in case the callback had chnged them
        Application.Run ThisWorkbook.Name & "!" & sCallBackProc, Nothing, 0, 0
 
    End If
 
End Sub
 
Public Property Get WorkSheetName() As String
 
    WorkSheetName = sSheetName
 
End Property
 
Public Property Let WorkSheetName(ByVal vNewValue As String)
 
    sSheetName = vNewValue
 
End Property
 
Public Property Get CallBackProcedure() As String
 
    CallBackProcedure = sCallBackProc
 
End Property
 
Public Property Let CallBackProcedure(ByVal vNewValue As String)
 
    sCallBackProc = vNewValue
 
End Property
 
Public Property Get IsMouseEventEnabled() As Boolean
 
    IsMouseEventEnabled = bMouseEventEnabled
 
End Property
 
Public Property Let IsMouseEventEnabled(ByVal vNewValue As Boolean)
 
    bMouseEventEnabled = vNewValue
 
End Property
 
Private Sub Class_Terminate()
 
    Me.Disable
 
End Sub
 
Private Sub WbEvent_BeforeClose(Cancel As Boolean)
 
    Me.Disable
 
End Sub

Any comments would be much appreciated.

Please, save your work bfore trying this as this could crash the system if not handled propperly


Last updated on 03/Oct/06.

Regards.

 

[Jaafar Tribak]

Jaleahmad,

I think, the problem is that you have the "Trust Visual Basic Project" box under the Macro security menu unchecked.

The code writes to the VBE so you will need to check that box before you open the workbook.

I tried a cleaner approach ( without using the VBE) some time ago but i can't , for the life of me, remember where i put the code. If i find the time, i'll rewrite the code again and post it here.


here is a fresh workbook demo and see if it works for you:
http://www.savefile.com/files/1559820

Note that the code is supposed to highlight ANY cell under the mouse cursor not just cell A1 but you can amend it to limit the job to one cell if u want.

Regards.

 

[Stormseed]

how the heck do I save this topic in my watch list (subscriptions) without posting a reply ?

 

[random_noise]

how the heck do I save this topic in my watch list (subscriptions) without posting a reply ?

Near the top of the thread - Thread Tools > Subscribe to this thread

(Although now you've posted to it you dont need to...)

 

[Jaafar Tribak]

Sorry for digging this old thread but i thought i would share with you this new approach which not only is much simpler, shorter and cleaner but it also overcomes all the problems of the other solutions provided so far.

Namely:
- No need to worry about the user's security settings as this doesn't use the VBE object model at all as the mouse watching routine runs in a background VBS file .

- No callbacks, timers or subclassing are used so the code is safe & persits even if the project is accidently reset !

-The MouseEvent handler is written in line with the standard design of excel events making it very intuitive , flexible & easy to write code in it .

Here is a workbook demo.

Code in the Workbook module :

Option Explicit
 
Public Event MouseMove(ByVal Target As Range)
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
 
Private Declare Function SetProp Lib "user32" _
Alias "SetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
 
Private Declare Function RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
 
Private Declare Function GetDesktopWindow Lib _
"user32.dll" () As Long
 
Private Declare Function GetCursorPos Lib "user32.dll" _
(ByRef lpPoint As POINTAPI) As Long
 
Private Declare Function OpenProcess Lib "Kernel32.dll" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
 
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
 
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
 
Private Const PROCESS_TERMINATE As Long = &H1
Private Const MOUSE_WATCHER_VBS As String _
= "C:\MouseWatcher.vbs"
 
Public Sub StartMouseWatcher(ByVal Sh As Worksheet)
 
Dim tPt As POINTAPI
Dim oTragetRange As Range
 
[COLOR=seagreen]'don't run the VBSript more than once.[/COLOR]
If GetProp(GetDesktopWindow, "lProcID") = 0 Then
    Call SetUpVBSFile
End If
 
[COLOR=seagreen]'hook the target sheet.[/COLOR]
CallByName Sh, "Worksheet", VbSet, ThisWorkbook
 
[COLOR=seagreen]'get the current cursor pos.[/COLOR]
GetCursorPos tPt
 
[COLOR=seagreen]'store the range under the mouse pointer.[/COLOR]
On Error Resume Next
Set oTragetRange = ActiveWindow.RangeFromPoint(tPt.x, tPt.y)
On Error GoTo 0
 
[COLOR=seagreen]'ignore non range objects and other sheets.[/COLOR]
If TypeName(oTragetRange) <> "Range" Or _
Not ActiveSheet Is Sh Then Exit Sub
 
[COLOR=seagreen]'pass the range to the MouseMove event.[/COLOR]
RaiseEvent MouseMove(ByVal oTragetRange)
 
End Sub
 
Public Sub StopMouseWatcher(ByVal DummySheet As Worksheet)
 
Dim hProcHandle As Long
Dim oTragetRange As Range
 
[COLOR=seagreen]'kill the VBScript exe.[/COLOR]
hProcHandle = OpenProcess(PROCESS_TERMINATE, 0, _
GetProp(GetDesktopWindow, "lProcID"))
TerminateProcess hProcHandle, 1
CloseHandle hProcHandle
 
[COLOR=seagreen]'run the last MouseMove event.[/COLOR]
RaiseEvent MouseMove(ByVal oTragetRange)
 
[COLOR=seagreen]'cleanup.[/COLOR]
RemoveProp GetDesktopWindow, "lProcID"
 
[COLOR=seagreen]'delete the temp vbs file.[/COLOR]
On Error Resume Next
Kill MOUSE_WATCHER_VBS
On Error GoTo 0
 
End Sub
 
Private Sub SetUpVBSFile()
 
    Dim lProcID As Long
 
    [COLOR=seagreen]'create a background vbs file on the fly.[/COLOR]
    Open MOUSE_WATCHER_VBS For Output As #1
    Print #1, "set wb=Getobject(" & Chr(34) & Me.FullName & Chr(34) & ")"
    Print #1, "On Error Resume Next"
    Print #1, "Do"
    Print #1, "wb.Application.Run(" & Chr(34) & Me.Name & _
    "!StartMouseMoveEvent" & Chr(34) & ")"
    Print #1, "Loop"
    Close #1
 
   [COLOR=seagreen]'execute the background vbs file.[/COLOR]
    lProcID = Shell("WScript.exe " & MOUSE_WATCHER_VBS)
 
    [COLOR=seagreen]'store the exe PID in a window to persist[/COLOR]
   [COLOR=seagreen]'even when the project is reset.[/COLOR]
    [COLOR=seagreen]'will be needed to terminate the process later.[/COLOR]
    SetProp GetDesktopWindow, "lProcID", lProcID
 
End Sub

Code in the worksheet module (taget sheet) :

Option Explicit
 
Public WithEvents Worksheet As ThisWorkbook
 
[COLOR=seagreen]'Using the custom MouseMove event to[/COLOR]
[COLOR=seagreen]'highlight the cell under the mouse pointer.[/COLOR]
[COLOR=seagreen]'==========================================[/COLOR]
Private Sub Worksheet_MouseMove(ByVal Target As Range)
 
    Static oPrvRange As Range
    Static lPrevCol As Variant
 
    On Error Resume Next
 
    If Target.Address <> oPrvRange.Address Then
        oPrvRange.Interior.ColorIndex = lPrevCol
        lPrevCol = Target.Interior.ColorIndex
        Target.Interior.ColorIndex = 3 'Red
        Set oPrvRange = Target
    End If
 
End Sub

This is how to start the event and to stop it ( in a standard module)

Option Explicit
 
Sub StartMouseMoveEvent()
    Call ThisWorkbook.StartMouseWatcher(ByVal Sheets(1))
End Sub
 
Sub StopMouseMoveEvent()
    Call ThisWorkbook.StopMouseWatcher(ByVal Sheets(1))
End Sub

Hope this will be of use.

Regards.

 

[Jaafar Tribak]

Note: Anyone downloading the Workbook demo above will first need to save it to disk before for it to work.

Regards.

 

[Jaafar Tribak]

Just one more thing. I forgot th scenario where the user may close the workbook before stopping the Mouse Event in which case the VBScript would not be terminated . This can easily be avoided by calling the StopMouseWatcher custom Method of the Workbook in the Workbook_BeforeClose event.

Workbook demo updated

Just add the following code to the Workbook module :

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    [COLOR=seagreen]'Just in case.[/COLOR]
    Call Me.StopMouseWatcher(Sheets(1))
 
End Sub

Regards.

 

[ljv004]

I have download and try, but The debuger says Access Error to route or file. Any suggestion???

 

[Jaafar Tribak]

I have download and try, but The debuger says Access Error to route or file. Any suggestion???

Where exactly does the code errors out ?