Can Excel unhide/hide rows just by hovering a mouse over it

A

atuljadhavnetafim

Active Member
Joined
Apr 7, 2012
Messages
341
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have values in D4 Cell which is sum of D5:D8 and again I have value in D9 cell which is sum of D10:D13 and so on......
now I don't want to use Group/Ungroup function because there are so many items in my excel and not practice to group/ungroup each time.
so what I want, whenever I hovering mouse to D4, excel slowly unhide Row 5 to 8 and once I remove mouse from D4 excel slowly hide those row.

I know this is possible in excel but just know howwwwww.

Thanks in advance
 
Sort by date Sort by votes
Hi dataluver

workbook sample

This worked for me in excel 2016 brilliantly specially for changing the shape mouse cursors.

Other excel versions didn't work as good;
Excel 2007 :, RangeFromPoint only works with Form and ActiveX controls... Doesn't work with standard shapes.
Excel 2010 : Setting the CursorImage Property doesnt work so the other 'CursorFile or SystemCursor' Props must be used instead. Also the cursor flickers
Excel 2013 : Not tested




ShapeEventsa5c91eaa63e75296.gif






1- CShapeMouseMoveEvents Class code:
VBA Code: 
Option Explicit

Private WithEvents MouseMove As CommandBars
Private WithEvents WB As Workbook

Public Enum CursorTypes
    IDC_ARROW = 32512
    IDC_IBEAM = 32513
    IDC_WAIT = 32514
    IDC_CROSS = 32515
    IDC_UPARROW = 32516
    IDC_SIZE = 32640
    IDC_ICON = 32641
    IDC_SIZENWSE = 32642
    IDC_SIZENESW = 32643
    IDC_SIZEWE = 32644
    IDC_SIZENS = 32645
    IDC_SIZEALL = 32646
    IDC_NO = 32648
    IDC_HAND = 32649
    IDC_APPSTARTING = 32650
End Enum

Private Type POINTAPI
        x As Long
        y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hCur As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As LongPtr) As LongPtr
#Else
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
    Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hCur As Long, ByVal id As Long) As Long
    Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If

Private oTTip As CToolTip
Private sShapeName As String
Private sWavFile As String
Private sCursorFile As String
Private oShpeObj As Object
Private sngLeft As Single, sngTop As Single
Private sngWidth As Single, sngHeight As Single
Private eSystemCursor As CursorTypes
Private oCursorImage As Object

Private Const SND_FILENAME = &H20000
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SPI_SETCURSORS = 87



Private Sub Class_Initialize()
    Call RestoreDefaultCursors
    Set MouseMove = Application.CommandBars
    Call MouseMove_OnUpdate
End Sub

Public Property Get ShapeObject() As Object
    Set ShapeObject = oShpeObj
End Property

Public Property Set ShapeObject(ByVal obj As Object)
    sngLeft = obj.Left: sngTop = obj.Top
    sngWidth = obj.Width: sngHeight = obj.Height
    Set oShpeObj = obj
    sShapeName = oShpeObj.Name
End Property

Public Property Get Left() As Single
    Left = sngLeft
End Property

Public Property Get Top() As Single
    Top = sngTop
End Property

Public Property Get Width() As Single
    Width = sngWidth
End Property

Public Property Get Height() As Single
    Height = sngHeight
End Property

Public Property Get ToolTip() As CToolTip
    Set ToolTip = oTTip
    Set ToolTip.AssociatedShape = oShpeObj
End Property

Public Property Set ToolTip(obj As CToolTip)
    Set oTTip = obj
End Property

Public Property Get ShapeName() As String
    ShapeName = sShapeName
End Property

Public Property Get GetWavFile() As String
    GetWavFile = sWavFile
End Property
Public Sub PlayWAV(ByVal WavFile As String)

    Dim oFolder As Object

    If Len(Dir(WavFile)) = 0 Then
        Set oFolder = CreateObject("Scripting.FileSystemObject").GetFolder(Environ("SystemRoot") & "\Media")
        WavFile = oFolder.Path & "\" & WavFile
    End If
   If Len(Dir(WavFile)) Then
            If PlaySound(WavFile, 0&, SND_ASYNC Or SND_NODEFAULT Or SND_FILENAME) Then
                sWavFile = WavFile
            End If
    End If

End Sub

Public Property Get SystemCursor() As CursorTypes
    SystemCursor = eSystemCursor
End Property
Public Property Let SystemCursor(ByVal CurID As CursorTypes)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Dim arCurs As Variant, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    For i = LBound(arCurs) To UBound(arCurs)
        hIcon = CopyIcon(LoadCursor(0&, CurID))
        If hIcon Then
            Call SetSystemCursor(hIcon, arCurs(i))
            DestroyIcon hIcon
        End If
    Next
    eSystemCursor = CurID

End Property


Public Property Get CursorFile() As String
    sCursorFile = CursorFile
End Property
Public Property Let CursorFile(ByVal IconFile As String)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Dim arCurs As Variant, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    For i = LBound(arCurs) To UBound(arCurs)
        hIcon = CopyIcon(LoadCursorFromFile(IconFile))
        If hIcon Then
            Call SetSystemCursor(hIcon, arCurs(i))
            DestroyIcon hIcon
        End If
    Next
    sCursorFile = IconFile

End Property


Public Property Get CursorImage() As Object
    Set CursorImage = oCursorImage
End Property
Public Property Set CursorImage(ByVal IconImage As Object)

    #If VBA7 Then
        Dim hIcon As LongPtr, hPic As LongPtr
    #Else
        Dim hIcon As Long, hPic As Long
    #End If

    Dim arCurs As Variant, oPic As Object, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    On Error Resume Next
        Set oPic = CallByName(IconImage, "Picture", VbGet) ' <== takes into account excel version.
        hPic = CallByName(oPic, "Handle", VbGet)
    On Error GoTo 0
  
    If hPic Then
        For i = LBound(arCurs) To UBound(arCurs)
            hIcon = CopyIcon(hPic)
            If hIcon Then
                Call SetSystemCursor(hIcon, arCurs(i))
                DestroyIcon hIcon
                Set oCursorImage = IconImage
            End If
        Next
    End If

End Property


Public Sub ToolTipDestroy()

    Dim shp As Shape

    Call RestoreDefaultCursors
    For Each shp In oShpeObj.Parent.Shapes
        If shp.AlternativeText = "@^\`|" Then
            shp.Delete
        End If
    Next shp
    Set oShpeObj = Nothing

End Sub


Private Sub MouseMove_OnUpdate()

    Static oShape As CShapeMouseMoveEvents
    Static oPrevObj As Object

    Dim oCurObj As Variant
    Dim tCurPos As POINTAPI

    If GetActiveWindow <> Application.hwnd Then Exit Sub
  
    On Error Resume Next

    GetCursorPos tCurPos
    Set oCurObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
  
    If oCurObj.Name <> ShapeName Then
        Call ToolTipDestroy
    End If
    
    If InStr(1, "RangeNothing", TypeName(oCurObj)) = 0 Then
        If Not oPrevObj Is Nothing Then
            If oCurObj.Name <> oPrevObj.Name Then
                Set oShape = Me
                Set oTTip = New CToolTip
                Set oShape.ShapeObject = oCurObj
                Call ThisWorkbook.ShapeMouseEnter(oShape)
            End If
        End If
    Else
        If Not oPrevObj Is Nothing Then
            If InStr(1, "RangeNothing", TypeName(oPrevObj)) = 0 Then
                If InStr(1, "RangeNothing", TypeName(oCurObj)) Then
                    If Not oShape Is Nothing Then
                            Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
                            Call ToolTipDestroy
                            Call ThisWorkbook.ShapeMouseLeave(oShape)
                            Call ReleaseVars
                    End If
                End If
                End If
            End If
    End If

    Set oPrevObj = oCurObj

    With Application.CommandBars.FindControl(id:=2020): .Enabled = Not .Enabled: End With

End Sub


Private Sub RestoreDefaultCursors()
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
End Sub

Private Sub ReleaseVars()
    sShapeName = ""
    sWavFile = ""
    sCursorFile = ""
    Set oShpeObj = Nothing
    sngLeft = 0: sngTop = 0
    sngWidth = 0: sngHeight = 0
    eSystemCursor = 0
    Set oCursorImage = Nothing
End Sub

Private Sub WB_BeforeClose(Cancel As Boolean)
    Call RestoreDefaultCursors 'Safety net !!.
End Sub



2- CToolTip Class code:
VBA Code: 
Option Explicit

Private WithEvents TTipTimer As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
#Else
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
#End If
Private Const SPI_SETCURSORS = 87

Private oTTip As Shape
Private oParentShape As Object
Private lShapeType As MsoAutoShapeType
Private sngWidth As Single, sngHeight As Single
Private sngTop As Single, sngLeft As Single
Private sngTransparency As Single
Private lBackColor As Long
Private lTxtCol As Long
Private sngFontSize As Single
Private lTimeOut As Long
Private sText As String
Private sFontName As String
Private lShadow As Boolean
Private lGradient As Boolean


Private Sub Class_Initialize()
    Call ToolTipDestroy
End Sub


Public Property Get ShapeType() As MsoAutoShapeType
    ShapeType = lShapeType
End Property
Public Property Let ShapeType(ByVal vNewValue As MsoAutoShapeType)
    lShapeType = vNewValue
    Set oTTip = oParentShape.Parent.Shapes.AddShape(vNewValue, 0, 0, 20, 20)
    oTTip.AlternativeText = "@^\`|"
End Property

Public Property Get AssociatedShape() As Object
    Set AssociatedShape = oParentShape
End Property
Public Property Set AssociatedShape(ByVal vNewValue As Object)
    Set oParentShape = vNewValue
End Property

Public Property Get Left() As Single
    Left = sngLeft
End Property
Public Property Let Left(ByVal vNewValue As Single)
    sngLeft = vNewValue
    oTTip.Left = vNewValue
End Property

Public Property Get Top() As Single
    Top = sngTop
End Property
Public Property Let Top(ByVal vNewValue As Single)
    sngTop = vNewValue
    oTTip.Top = vNewValue
End Property

Public Property Get Width() As Single
    Width = sngWidth
End Property
Public Property Let Width(ByVal vNewValue As Single)
    sngWidth = vNewValue
    oTTip.Width = vNewValue
End Property

Public Property Get Height() As Single
    Height = sngHeight
End Property
Public Property Let Height(ByVal vNewValue As Single)
    sngHeight = vNewValue
    oTTip.Height = vNewValue
End Property

Public Property Get BackColor() As Long
    BackColor = lBackColor
End Property
Public Property Let BackColor(ByVal vNewValue As Long)
    lBackColor = vNewValue
    oTTip.Fill.ForeColor.RGB = lBackColor
End Property

Public Property Get Text() As String
    Text = sText
End Property
Public Property Let Text(ByVal vNewValue As String)
    sText = vNewValue
    With oTTip.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorCenter
        .TextRange.Characters.Text = vNewValue
    End With
End Property

Public Property Get TextColor() As Long
    TextColor = lTxtCol
End Property
Public Property Let TextColor(ByVal vNewValue As Long)
    lTxtCol = vNewValue
    oTTip.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vNewValue
End Property

Public Property Get FontName() As String
    FontName = sFontName
End Property
Public Property Let FontName(ByVal vNewValue As String)
    sFontName = vNewValue
    oTTip.TextFrame2.TextRange.Font.Name = vNewValue
End Property

Public Property Get FontSize() As Single
    FontSize = sngFontSize
End Property
Public Property Let FontSize(ByVal vNewValue As Single)
    If vNewValue <= 4 Or vNewValue > 20 Then vNewValue = 10
    sngFontSize = vNewValue
    oTTip.TextFrame2.TextRange.Font.Size = vNewValue
End Property

Public Property Get GradientFill() As Boolean
    GradientFill = lGradient
End Property
Public Property Let GradientFill(ByVal vNewValue As Boolean)
    lGradient = vNewValue
    If vNewValue Then
        oTTip.Fill.TwoColorGradient msoGradientDiagonalUp, 1
    End If
End Property

Public Property Get Transparency() As Single
    Transparency = sngTransparency
End Property
Public Property Let Transparency(ByVal vNewValue As Single)
    If vNewValue < 0 Then vNewValue = 0
    If vNewValue > 1 Then vNewValue = 1
    sngTransparency = vNewValue
    oTTip.Fill.Transparency = vNewValue
End Property

Public Property Get Shadow() As Boolean
    Shadow = lShadow
End Property
Public Property Let Shadow(ByVal vNewValue As Boolean)
    lShadow = vNewValue
    If vNewValue Then
        oTTip.Shadow.Type = msoShadow16
    End If
End Property

Public Property Get TimeOut() As Long
    TimeOut = lTimeOut
End Property
Public Property Let TimeOut(ByVal vNewValue As Long)
    lTimeOut = vNewValue
    If vNewValue > 0 Then
        Set TTipTimer = Application.CommandBars
        Call TTipTimer_OnUpdate
    End If
End Property


Public Sub ToolTipDestroy()

    Dim shp As Shape

    Call RestoreDefaultCursors
    For Each shp In ActiveSheet.Shapes
        If shp.AlternativeText = "@^\`|" Then
            shp.Delete
        End If
    Next shp

End Sub


Private Sub TTipTimer_OnUpdate()

    Static lPrevTime As Long
  
    On Error Resume Next
  
    If lPrevTime Then
        If Int(Timer) - lPrevTime >= lTimeOut - 1 Then
            If Not oTTip Is Nothing Then
                Set TTipTimer = Nothing
                oTTip.Delete
            End If
        End If
    End If
    If lPrevTime = 0 Then
        lPrevTime = Timer
    End If
    With Application.CommandBars.FindControl(id:=2020): .Enabled = Not .Enabled: End With
End Sub


Private Sub RestoreDefaultCursors()
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
End Sub



3- Example of code usage in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private oShapeMouseMove As CShapeMouseMoveEvents


Private Sub Workbook_Activate()
     EnableShapelMouseMoveEvents = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
     EnableShapelMouseMoveEvents = False
End Sub

Private Property Let EnableShapelMouseMoveEvents(ByVal Enable As Boolean)
    If Enable Then
        Set oShapeMouseMove = New CShapeMouseMoveEvents
    Else
        Set oShapeMouseMove = Nothing
    End If
End Property




'__________________________________________PSEUDO_EVENTS________________________________________________________________

Friend Sub ShapeMouseEnter(Target As CShapeMouseMoveEvents)

    Select Case Target.ShapeName
  
        Case "Button 1"
      
            [B2] = Target.ShapeName
            Target.PlayWAV "tada.wav"
            Target.SystemCursor = IDC_CROSS '<= Alternatively,use the 'CursorFile' or 'CursorImage' properties.
            With Target.ToolTip
                .ShapeType = msoShapeCloudCallout '<= This ToolTip Prop Must be set first !!!
                .Width = 120
                .Height = 60
                .Left = Target.ShapeObject.Left + Target.ShapeObject.Width - 20
                .Top = Target.ShapeObject.Top - .Height - 20
                .BackColor = vbCyan
                .Text = "hey!!!!"
                .FontName = "Bradley Hand ITC"
                .FontSize = 18
                .TextColor = vbMagenta
                .GradientFill = True
                .Shadow = True
                .Transparency = 0.5
            End With
          
            Call DisplayInfo(Target)
      
        Case "CommandButton1"
      
            [B2] = Target.ShapeName
            Target.PlayWAV "ding.wav"
            Set Target.CursorImage = Sheet1.Image1 '<= Alternatively,use the 'CursorFile' or 'SystemCursor' properties.
            With Target.ToolTip
                .ShapeType = msoShape8pointStar '<= This ToolTip Prop Must be set first !!!
                .Width = 140
                .Height = 60
                .Left = Target.ShapeObject.Left - .Width + 10
                .Top = Target.ShapeObject.Top - .Height
                .Text = "Timed Tip"
                .FontName = "ALGERIAN"
                .FontSize = 16
                ' .GradientFill = True
                .TextColor = vbYellow
                .TimeOut = 3 'secs.
                .BackColor = vbRed
                .Transparency = 0.1
                ' .Shadow = True
            End With
          
            Call DisplayInfo(Target)
      
        Case "Oval 1"
      
            [B2] = Target.ShapeName
            Target.PlayWAV "ding.wav"
            Set Target.CursorImage = Sheet1.Image3 '<= Alternatively,use the 'CursorFile' or 'SystemCursor' properties.
            With Target.ToolTip
                .ShapeType = msoShapeOctagon '<= This ToolTip Prop Must be set first !!!
                .Width = 100
                .Height = 100
                .Left = Target.ShapeObject.Left - .Width
                .Top = Target.ShapeObject.Top - .Height + 50
                .Text = "MrExcel"
                .FontName = "CASTELLAR"
                .FontSize = 30
                .GradientFill = True
                .TextColor = vbBlack
                ' .TimeOut = 3 'secs.
                .BackColor = RGB(100, 10, 100)
                .Transparency = 0.4
                ' .Shadow = True
            End With
          
            Call DisplayInfo(Target)
  
    End Select

End Sub

Friend Sub ShapeMouseLeave(Target As CShapeMouseMoveEvents)

    If Target.ShapeName = "Button 1" Or Target.ShapeName = "CommandButton1" Or Target.ShapeName = "Oval 1" Then
        [B3] = Target.ShapeName
    End If
    Range("B5:B25").ClearContents

End Sub


Private Sub DisplayInfo(Target As CShapeMouseMoveEvents)

    With Target
        [B5] = IIf(.GetWavFile = "", "N/A", .GetWavFile)
        [B6] = IIf(.SystemCursor = 0, "N/A", .SystemCursor)
        [B7] = IIf(.CursorFile = "", "N/A", .CursorFile)
        On Error Resume Next
            [B8] = IIf(.CursorImage.Name = "", "N/A", .CursorImage.Name) 'excel 2016
        On Error GoTo 0
        With .ToolTip
            [B11] = .ShapeType
            [B12] = .AssociatedShape.Name
            [B13] = .Left
            [B14] = .Top
            [B15] = .Width
            [B16] = .Height
            [B17] = .BackColor
            [B18] = .Text
            [B19] = .TextColor
            [B20] = .FontName
            [B21] = .FontSize
            [B22] = .GradientFill
            [B23] = .Transparency
            [B24] = .Shadow
            [B25] = IIf(.TimeOut = 0, "N/A", .TimeOut)
        End With
    End With

End Sub
 
Upvote 0

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
:) Jafaar, you crack me up. I thought that I went over the top on this thread. You went over the top of the top. This works great in my version. Office 365 Business. Don't know what year that would be, but supposedly I always have the latest and greatest. Thanks for all of your interesting solutions over the years.

Link to the same file as above --> "Jafaar ShapeEvents.xlsm"
 
Upvote 0
Jaafar Tribak said:
Hi dataluver

workbook sample

This worked for me in excel 2016 brilliantly specially for changing the shape mouse cursors.

Other excel versions didn't work as good;
Excel 2007 :, RangeFromPoint only works with Form and ActiveX controls... Doesn't work with standard shapes.
Excel 2010 : Setting the CursorImage Property doesnt work so the other 'CursorFile or SystemCursor' Props must be used instead. Also the cursor flickers
Excel 2013 : Not tested




ShapeEventsa5c91eaa63e75296.gif






1- CShapeMouseMoveEvents Class code:
VBA Code: 
Option Explicit

Private WithEvents MouseMove As CommandBars
Private WithEvents WB As Workbook

Public Enum CursorTypes
    IDC_ARROW = 32512
    IDC_IBEAM = 32513
    IDC_WAIT = 32514
    IDC_CROSS = 32515
    IDC_UPARROW = 32516
    IDC_SIZE = 32640
    IDC_ICON = 32641
    IDC_SIZENWSE = 32642
    IDC_SIZENESW = 32643
    IDC_SIZEWE = 32644
    IDC_SIZENS = 32645
    IDC_SIZEALL = 32646
    IDC_NO = 32648
    IDC_HAND = 32649
    IDC_APPSTARTING = 32650
End Enum

Private Type POINTAPI
        x As Long
        y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CopyIcon Lib "user32" (ByVal hIcon As LongPtr) As LongPtr
    Private Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As LongPtr, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hCur As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As LongPtr) As LongPtr
#Else
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long
    Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hCur As Long, ByVal id As Long) As Long
    Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If

Private oTTip As CToolTip
Private sShapeName As String
Private sWavFile As String
Private sCursorFile As String
Private oShpeObj As Object
Private sngLeft As Single, sngTop As Single
Private sngWidth As Single, sngHeight As Single
Private eSystemCursor As CursorTypes
Private oCursorImage As Object

Private Const SND_FILENAME = &H20000
Private Const SND_ASYNC = &H1
Private Const SND_NODEFAULT = &H2
Private Const SPI_SETCURSORS = 87



Private Sub Class_Initialize()
    Call RestoreDefaultCursors
    Set MouseMove = Application.CommandBars
    Call MouseMove_OnUpdate
End Sub

Public Property Get ShapeObject() As Object
    Set ShapeObject = oShpeObj
End Property

Public Property Set ShapeObject(ByVal obj As Object)
    sngLeft = obj.Left: sngTop = obj.Top
    sngWidth = obj.Width: sngHeight = obj.Height
    Set oShpeObj = obj
    sShapeName = oShpeObj.Name
End Property

Public Property Get Left() As Single
    Left = sngLeft
End Property

Public Property Get Top() As Single
    Top = sngTop
End Property

Public Property Get Width() As Single
    Width = sngWidth
End Property

Public Property Get Height() As Single
    Height = sngHeight
End Property

Public Property Get ToolTip() As CToolTip
    Set ToolTip = oTTip
    Set ToolTip.AssociatedShape = oShpeObj
End Property

Public Property Set ToolTip(obj As CToolTip)
    Set oTTip = obj
End Property

Public Property Get ShapeName() As String
    ShapeName = sShapeName
End Property

Public Property Get GetWavFile() As String
    GetWavFile = sWavFile
End Property
Public Sub PlayWAV(ByVal WavFile As String)

    Dim oFolder As Object

    If Len(Dir(WavFile)) = 0 Then
        Set oFolder = CreateObject("Scripting.FileSystemObject").GetFolder(Environ("SystemRoot") & "\Media")
        WavFile = oFolder.Path & "\" & WavFile
    End If
   If Len(Dir(WavFile)) Then
            If PlaySound(WavFile, 0&, SND_ASYNC Or SND_NODEFAULT Or SND_FILENAME) Then
                sWavFile = WavFile
            End If
    End If

End Sub

Public Property Get SystemCursor() As CursorTypes
    SystemCursor = eSystemCursor
End Property
Public Property Let SystemCursor(ByVal CurID As CursorTypes)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Dim arCurs As Variant, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    For i = LBound(arCurs) To UBound(arCurs)
        hIcon = CopyIcon(LoadCursor(0&, CurID))
        If hIcon Then
            Call SetSystemCursor(hIcon, arCurs(i))
            DestroyIcon hIcon
        End If
    Next
    eSystemCursor = CurID

End Property


Public Property Get CursorFile() As String
    sCursorFile = CursorFile
End Property
Public Property Let CursorFile(ByVal IconFile As String)

    #If VBA7 Then
        Dim hIcon As LongPtr
    #Else
        Dim hIcon As Long
    #End If

    Dim arCurs As Variant, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    For i = LBound(arCurs) To UBound(arCurs)
        hIcon = CopyIcon(LoadCursorFromFile(IconFile))
        If hIcon Then
            Call SetSystemCursor(hIcon, arCurs(i))
            DestroyIcon hIcon
        End If
    Next
    sCursorFile = IconFile

End Property


Public Property Get CursorImage() As Object
    Set CursorImage = oCursorImage
End Property
Public Property Set CursorImage(ByVal IconImage As Object)

    #If VBA7 Then
        Dim hIcon As LongPtr, hPic As LongPtr
    #Else
        Dim hIcon As Long, hPic As Long
    #End If

    Dim arCurs As Variant, oPic As Object, i As Long

    arCurs = Array(IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENWSE, IDC_SIZENESW, IDC_SIZEWE, IDC_SIZENS, IDC_SIZEALL, IDC_NO, IDC_HAND, IDC_APPSTARTING)

    On Error Resume Next
        Set oPic = CallByName(IconImage, "Picture", VbGet) ' <== takes into account excel version.
        hPic = CallByName(oPic, "Handle", VbGet)
    On Error GoTo 0
 
    If hPic Then
        For i = LBound(arCurs) To UBound(arCurs)
            hIcon = CopyIcon(hPic)
            If hIcon Then
                Call SetSystemCursor(hIcon, arCurs(i))
                DestroyIcon hIcon
                Set oCursorImage = IconImage
            End If
        Next
    End If

End Property


Public Sub ToolTipDestroy()

    Dim shp As Shape

    Call RestoreDefaultCursors
    For Each shp In oShpeObj.Parent.Shapes
        If shp.AlternativeText = "@^\`|" Then
            shp.Delete
        End If
    Next shp
    Set oShpeObj = Nothing

End Sub


Private Sub MouseMove_OnUpdate()

    Static oShape As CShapeMouseMoveEvents
    Static oPrevObj As Object

    Dim oCurObj As Variant
    Dim tCurPos As POINTAPI

    If GetActiveWindow <> Application.hwnd Then Exit Sub
 
    On Error Resume Next

    GetCursorPos tCurPos
    Set oCurObj = ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)
 
    If oCurObj.Name <> ShapeName Then
        Call ToolTipDestroy
    End If
   
    If InStr(1, "RangeNothing", TypeName(oCurObj)) = 0 Then
        If Not oPrevObj Is Nothing Then
            If oCurObj.Name <> oPrevObj.Name Then
                Set oShape = Me
                Set oTTip = New CToolTip
                Set oShape.ShapeObject = oCurObj
                Call ThisWorkbook.ShapeMouseEnter(oShape)
            End If
        End If
    Else
        If Not oPrevObj Is Nothing Then
            If InStr(1, "RangeNothing", TypeName(oPrevObj)) = 0 Then
                If InStr(1, "RangeNothing", TypeName(oCurObj)) Then
                    If Not oShape Is Nothing Then
                            Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
                            Call ToolTipDestroy
                            Call ThisWorkbook.ShapeMouseLeave(oShape)
                            Call ReleaseVars
                    End If
                End If
                End If
            End If
    End If

    Set oPrevObj = oCurObj

    With Application.CommandBars.FindControl(id:=2020): .Enabled = Not .Enabled: End With

End Sub


Private Sub RestoreDefaultCursors()
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
End Sub

Private Sub ReleaseVars()
    sShapeName = ""
    sWavFile = ""
    sCursorFile = ""
    Set oShpeObj = Nothing
    sngLeft = 0: sngTop = 0
    sngWidth = 0: sngHeight = 0
    eSystemCursor = 0
    Set oCursorImage = Nothing
End Sub

Private Sub WB_BeforeClose(Cancel As Boolean)
    Call RestoreDefaultCursors 'Safety net !!.
End Sub



2- CToolTip Class code:
VBA Code: 
Option Explicit

Private WithEvents TTipTimer As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
#Else
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
#End If
Private Const SPI_SETCURSORS = 87

Private oTTip As Shape
Private oParentShape As Object
Private lShapeType As MsoAutoShapeType
Private sngWidth As Single, sngHeight As Single
Private sngTop As Single, sngLeft As Single
Private sngTransparency As Single
Private lBackColor As Long
Private lTxtCol As Long
Private sngFontSize As Single
Private lTimeOut As Long
Private sText As String
Private sFontName As String
Private lShadow As Boolean
Private lGradient As Boolean


Private Sub Class_Initialize()
    Call ToolTipDestroy
End Sub


Public Property Get ShapeType() As MsoAutoShapeType
    ShapeType = lShapeType
End Property
Public Property Let ShapeType(ByVal vNewValue As MsoAutoShapeType)
    lShapeType = vNewValue
    Set oTTip = oParentShape.Parent.Shapes.AddShape(vNewValue, 0, 0, 20, 20)
    oTTip.AlternativeText = "@^\`|"
End Property

Public Property Get AssociatedShape() As Object
    Set AssociatedShape = oParentShape
End Property
Public Property Set AssociatedShape(ByVal vNewValue As Object)
    Set oParentShape = vNewValue
End Property

Public Property Get Left() As Single
    Left = sngLeft
End Property
Public Property Let Left(ByVal vNewValue As Single)
    sngLeft = vNewValue
    oTTip.Left = vNewValue
End Property

Public Property Get Top() As Single
    Top = sngTop
End Property
Public Property Let Top(ByVal vNewValue As Single)
    sngTop = vNewValue
    oTTip.Top = vNewValue
End Property

Public Property Get Width() As Single
    Width = sngWidth
End Property
Public Property Let Width(ByVal vNewValue As Single)
    sngWidth = vNewValue
    oTTip.Width = vNewValue
End Property

Public Property Get Height() As Single
    Height = sngHeight
End Property
Public Property Let Height(ByVal vNewValue As Single)
    sngHeight = vNewValue
    oTTip.Height = vNewValue
End Property

Public Property Get BackColor() As Long
    BackColor = lBackColor
End Property
Public Property Let BackColor(ByVal vNewValue As Long)
    lBackColor = vNewValue
    oTTip.Fill.ForeColor.RGB = lBackColor
End Property

Public Property Get Text() As String
    Text = sText
End Property
Public Property Let Text(ByVal vNewValue As String)
    sText = vNewValue
    With oTTip.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .HorizontalAnchor = msoAnchorCenter
        .TextRange.Characters.Text = vNewValue
    End With
End Property

Public Property Get TextColor() As Long
    TextColor = lTxtCol
End Property
Public Property Let TextColor(ByVal vNewValue As Long)
    lTxtCol = vNewValue
    oTTip.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vNewValue
End Property

Public Property Get FontName() As String
    FontName = sFontName
End Property
Public Property Let FontName(ByVal vNewValue As String)
    sFontName = vNewValue
    oTTip.TextFrame2.TextRange.Font.Name = vNewValue
End Property

Public Property Get FontSize() As Single
    FontSize = sngFontSize
End Property
Public Property Let FontSize(ByVal vNewValue As Single)
    If vNewValue <= 4 Or vNewValue > 20 Then vNewValue = 10
    sngFontSize = vNewValue
    oTTip.TextFrame2.TextRange.Font.Size = vNewValue
End Property

Public Property Get GradientFill() As Boolean
    GradientFill = lGradient
End Property
Public Property Let GradientFill(ByVal vNewValue As Boolean)
    lGradient = vNewValue
    If vNewValue Then
        oTTip.Fill.TwoColorGradient msoGradientDiagonalUp, 1
    End If
End Property

Public Property Get Transparency() As Single
    Transparency = sngTransparency
End Property
Public Property Let Transparency(ByVal vNewValue As Single)
    If vNewValue < 0 Then vNewValue = 0
    If vNewValue > 1 Then vNewValue = 1
    sngTransparency = vNewValue
    oTTip.Fill.Transparency = vNewValue
End Property

Public Property Get Shadow() As Boolean
    Shadow = lShadow
End Property
Public Property Let Shadow(ByVal vNewValue As Boolean)
    lShadow = vNewValue
    If vNewValue Then
        oTTip.Shadow.Type = msoShadow16
    End If
End Property

Public Property Get TimeOut() As Long
    TimeOut = lTimeOut
End Property
Public Property Let TimeOut(ByVal vNewValue As Long)
    lTimeOut = vNewValue
    If vNewValue > 0 Then
        Set TTipTimer = Application.CommandBars
        Call TTipTimer_OnUpdate
    End If
End Property


Public Sub ToolTipDestroy()

    Dim shp As Shape

    Call RestoreDefaultCursors
    For Each shp In ActiveSheet.Shapes
        If shp.AlternativeText = "@^\`|" Then
            shp.Delete
        End If
    Next shp

End Sub


Private Sub TTipTimer_OnUpdate()

    Static lPrevTime As Long
 
    On Error Resume Next
 
    If lPrevTime Then
        If Int(Timer) - lPrevTime >= lTimeOut - 1 Then
            If Not oTTip Is Nothing Then
                Set TTipTimer = Nothing
                oTTip.Delete
            End If
        End If
    End If
    If lPrevTime = 0 Then
        lPrevTime = Timer
    End If
    With Application.CommandBars.FindControl(id:=2020): .Enabled = Not .Enabled: End With
End Sub


Private Sub RestoreDefaultCursors()
    Call SystemParametersInfo(SPI_SETCURSORS, 0, 0, 0)
End Sub



3- Example of code usage in the ThisWorkbook Module:
VBA Code: 
Option Explicit

Private oShapeMouseMove As CShapeMouseMoveEvents


Private Sub Workbook_Activate()
     EnableShapelMouseMoveEvents = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
     EnableShapelMouseMoveEvents = False
End Sub

Private Property Let EnableShapelMouseMoveEvents(ByVal Enable As Boolean)
    If Enable Then
        Set oShapeMouseMove = New CShapeMouseMoveEvents
    Else
        Set oShapeMouseMove = Nothing
    End If
End Property




'__________________________________________PSEUDO_EVENTS________________________________________________________________

Friend Sub ShapeMouseEnter(Target As CShapeMouseMoveEvents)

    Select Case Target.ShapeName
 
        Case "Button 1"
     
            [B2] = Target.ShapeName
            Target.PlayWAV "tada.wav"
            Target.SystemCursor = IDC_CROSS '<= Alternatively,use the 'CursorFile' or 'CursorImage' properties.
            With Target.ToolTip
                .ShapeType = msoShapeCloudCallout '<= This ToolTip Prop Must be set first !!!
                .Width = 120
                .Height = 60
                .Left = Target.ShapeObject.Left + Target.ShapeObject.Width - 20
                .Top = Target.ShapeObject.Top - .Height - 20
                .BackColor = vbCyan
                .Text = "hey!!!!"
                .FontName = "Bradley Hand ITC"
                .FontSize = 18
                .TextColor = vbMagenta
                .GradientFill = True
                .Shadow = True
                .Transparency = 0.5
            End With
         
            Call DisplayInfo(Target)
     
        Case "CommandButton1"
     
            [B2] = Target.ShapeName
            Target.PlayWAV "ding.wav"
            Set Target.CursorImage = Sheet1.Image1 '<= Alternatively,use the 'CursorFile' or 'SystemCursor' properties.
            With Target.ToolTip
                .ShapeType = msoShape8pointStar '<= This ToolTip Prop Must be set first !!!
                .Width = 140
                .Height = 60
                .Left = Target.ShapeObject.Left - .Width + 10
                .Top = Target.ShapeObject.Top - .Height
                .Text = "Timed Tip"
                .FontName = "ALGERIAN"
                .FontSize = 16
                ' .GradientFill = True
                .TextColor = vbYellow
                .TimeOut = 3 'secs.
                .BackColor = vbRed
                .Transparency = 0.1
                ' .Shadow = True
            End With
         
            Call DisplayInfo(Target)
     
        Case "Oval 1"
     
            [B2] = Target.ShapeName
            Target.PlayWAV "ding.wav"
            Set Target.CursorImage = Sheet1.Image3 '<= Alternatively,use the 'CursorFile' or 'SystemCursor' properties.
            With Target.ToolTip
                .ShapeType = msoShapeOctagon '<= This ToolTip Prop Must be set first !!!
                .Width = 100
                .Height = 100
                .Left = Target.ShapeObject.Left - .Width
                .Top = Target.ShapeObject.Top - .Height + 50
                .Text = "MrExcel"
                .FontName = "CASTELLAR"
                .FontSize = 30
                .GradientFill = True
                .TextColor = vbBlack
                ' .TimeOut = 3 'secs.
                .BackColor = RGB(100, 10, 100)
                .Transparency = 0.4
                ' .Shadow = True
            End With
         
            Call DisplayInfo(Target)
 
    End Select

End Sub

Friend Sub ShapeMouseLeave(Target As CShapeMouseMoveEvents)

    If Target.ShapeName = "Button 1" Or Target.ShapeName = "CommandButton1" Or Target.ShapeName = "Oval 1" Then
        [B3] = Target.ShapeName
    End If
    Range("B5:B25").ClearContents

End Sub


Private Sub DisplayInfo(Target As CShapeMouseMoveEvents)

    With Target
        [B5] = IIf(.GetWavFile = "", "N/A", .GetWavFile)
        [B6] = IIf(.SystemCursor = 0, "N/A", .SystemCursor)
        [B7] = IIf(.CursorFile = "", "N/A", .CursorFile)
        On Error Resume Next
            [B8] = IIf(.CursorImage.Name = "", "N/A", .CursorImage.Name) 'excel 2016
        On Error GoTo 0
        With .ToolTip
            [B11] = .ShapeType
            [B12] = .AssociatedShape.Name
            [B13] = .Left
            [B14] = .Top
            [B15] = .Width
            [B16] = .Height
            [B17] = .BackColor
            [B18] = .Text
            [B19] = .TextColor
            [B20] = .FontName
            [B21] = .FontSize
            [B22] = .GradientFill
            [B23] = .Transparency
            [B24] = .Shadow
            [B25] = IIf(.TimeOut = 0, "N/A", .TimeOut)
        End With
    End With

End Sub
Click to expand...
I am using these codes. Everthing is okay also I am using these in MouseOver function. But mouseIcon is only showing together default mouse when mouse move and every time it returns default state. can you please help me
 
Upvote 0
orkhan12345 said:
I am using these codes. Everthing is okay also I am using these in MouseOver function. But mouseIcon is only showing together default mouse when mouse move and every time it returns default state. can you please help me
Click to expand...
Also i would inform that i am not using these for excel.
 
Upvote 0
You must log in or register to reply here.

Similar threads

CyrusTheVirus
  • Question
New Excel Changes - Looking for advice
Replies
4
Views
106
CyrusTheVirus
CyrusTheVirus
R
  • Solved
Hide rows according to checkboxes on seperate sheet
Replies
8
Views
115
John_w
J
R
  • Question
Help with auto Hide/Unhide rows without rerunning VBA
Replies
0
Views
1K
RDM1126
R
GMC The Macro Man
  • Question
Clear Data without VBA
2
Replies
12
Views
636
mumps
mumps
charlesstricklin
  • Solved
Split week's dates by month?
Replies
7
Views
200
rlv01
R

Forum statistics

Threads
1,214,806
Messages
6,121,672
Members
449,045
Latest member
Marcus05

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top