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

 

[DougStroud]

Ok, Got it.
I either needed to save the workbook and then try it or close it and reopen it for Ivan's to work.

Thanks Tom

Doug

 

[Jaafar Tribak]

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.

 

[bsnapool]

Erdinç E. Karaçam

Just out of interest.. Why would you need this sort of code?

 

[Ivan F Moala]

Tom

Much better implimentation of original !! .... better performance. THANKS
On my machine, CPU 4% - 22%



Jaafar

Great class that shows great implimentation of using another instance of Xl and coding to the VBE to overcome the timer. Good work.

On my machine it opened Xl2007, that been the latest registered Version and NOT another instance of my currently open version = Xl2003.
So yes you warning of the setup to have macros enabled and to trust access to the VBE will be a valid drawback. In fact if you do Error handling for the instances where access to the VBE is NOT trusted then you will need to consider PC's with multiple versions of Xl that may ? have different settings then the current instance of Xl. I u 2000, 2003 and 2007 (Beta 2).

Jaafar, GOOD WORK

 

[Jaafar Tribak]

Tom

Much better implimentation of original !! .... better performance. THANKS
On my machine, CPU 4% - 22%



Jaafar

Great class that shows great implimentation of using another instance of Xl and coding to the VBE to overcome the timer. Good work.

On my machine it opened Xl2007, that been the latest registered Version and NOT another instance of my currently open version = Xl2003.
So yes you warning of the setup to have macros enabled and to trust access to the VBE will be a valid drawback. In fact if you do Error handling for the instances where access to the VBE is NOT trusted then you will need to consider PC's with multiple versions of Xl that may ? have different settings then the current instance of Xl. I u 2000, 2003 and 2007 (Beta 2).

Jaafar, GOOD WORK

Thanks for the feedback Ivan.

 

[Erdinç E. Karaçam]

Erdinç E. Karaçam

Just out of interest.. Why would you need this sort of code?

Hi everyone!
I was very busy, sorry.

Actually i need this code for one of my friend. I have already share the code with him.

But from now on i can use this codes in some analyses works.

But, for at the moment i only keep this codes.

By the way, i worked on teh code for some different samples.

For example, depends on a condition;

If cell value includes "ERDİNÇ" then code will run... and something like this.

Option Explicit

'// Bu API'nin özgün halinin yazarı, Yeni Zellanda - Auckland'dan Sayın Ivan F Moala'dır.
'// Nazik paylaşımı için kendisine teşekkür ederim. 01.10.2006
'// Ben sadece API'ye Koşullara göre çalışması için kodlar ekledim.

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 m_blnTimerOn As Boolean
Dim m_lngTimerId As Long
Dim m_NewRange As Range
Dim m_OldRange As Range

Sub StartTimer()
If Not m_blnTimerOn Then
    m_lngTimerId = SetTimer(0, 0, 0.05, AddressOf TimerProc)
    m_blnTimerOn = True
End If
End Sub

Public Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim lngCurPos As POINTAPI

On Error Resume Next
GetCursorPos lngCurPos

Set m_NewRange = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.Y)

If m_NewRange.Address <> m_OldRange.Address Then
    With Cells
        .Font.ColorIndex = 0
        .Interior.ColorIndex = xlNone
        .Font.Italic = False
    End With
End If

If m_NewRange.Value <> "" Then
    Dim Hucre As Range
    Dim Kosul As String
    Kosul = "ERDİNÇ"
    Kosul = "*" & Kosul & "*"
        For Each Hucre In m_NewRange
            If WorksheetFunction.CountIf(Hucre, Kosul) > 0 Then
                With Hucre
                    .Font.ColorIndex = 3
                    .Interior.ColorIndex = 6
                    .Font.Italic = True
                End With
            End If
        Next Hucre
End If
    
'//
Set m_OldRange = m_NewRange
TimerProc = 0

End Function

Sub StopTimer()
    If m_blnTimerOn Then
        KillTimer 0, m_lngTimerId
        m_blnTimerOn = False
    End If
End Sub

 

[Legacy 98055]

Hi Ivan. Your welcome.
Jaafar. I enjoyed your example and was surprised that the performace was as good as it was. I would not have even considered passing so much data such as a mouse move by way of a separate exe as I have been under the impression that it is a bad idea to pass so much data by way of cross process marshalling. Nevertheless, there were no apparent problems with your code at all. Could you place your timer code in another workbook and then open that workbook in a separate instance to get around the VB security issue?

 

[Ivan F Moala]

Hi Ivan. Your welcome.
Jaafar. I enjoyed your example and was surprised that the performace was as good as it was. I would not have even considered passing so much data such as a mouse move by way of a separate exe as I have been under the impression that it is a bad idea to pass so much data by way of cross process marshalling. Nevertheless, there were no apparent problems with your code at all. Could you place your timer code in another workbook and then open that workbook in a separate instance to get around the VB security issue?

Tom, your welcome as usual. With Jaafar's code there is no noticeable lag there is an increase overall in CPU usage, more then your code. What I liked with Jaafar was the thinking out side the square and trying something else, something I always try to do. I have kept both codes and will use them as examples on my site.

 

[2Istanbul]

do you speak italian?

 

[Jaafar Tribak]

Could you place your timer code in another workbook and then open that workbook in a separate instance to get around the VB security issue?

Tom,

Good idea! perhaps the Timer code should be placed in an addin or Personal.xls rather than a normal workbook . that way, one can be sure it's always loaded and accessible.

I have just updated the Class code to handle the following unlikely scenario : If the user was to close the current Workbook before terminating the Class, the newly added XL instance would remain in memory together with a running timer which would be a disaster !

I have done this simply by incorporating a BeforeClose event handler to the Class code.

Another update I have added is to do with validation code to cater for the situation where Access to the Vbproject is not trusted.
The user will now be prompted to change the Security Macro Settings before they can use the Class.

Other bits & pieces also added to maximise performance by reducing the timer code.

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

Regards.