bradyboyy88
Well-known Member
- Joined
- Feb 25, 2015
- Messages
- 562
I have created 1000s of labels at runtime and I want to add a hover effect to them. The labels are originally designed as a white background and when you hover should go light grey and when clicked go dark grey. If you are not hovered over it anymore it should go back to its original color vbWhite. I am trying to use some code previously provided by Raj below but I am having trouble getting it to work as being a label. The other issue is his code utilizes the tag option of the label and I do not want to touch the tag because I save additional information in there for a click event later on. Can this be done without using the tag?
Rich (BB code):
Option Explicit
Public WithEvents Lbl As MSForms.Label
Private Type POINTAPI
X As Long
Y As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
#Else
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Private Const CHILDID_SELF = vbWhite 'White
Private Const HOVER_COLOR As Long = &H00E0E0E0& 'Light Grey
Private Const ACTIVE_COLOR As Long = &H00C0C0C0& 'Dark Grey
Private bClicked As Boolean
Private Sub Lbl_Click()
Dim oCtl As Control
If Lbl.Parent.Name = "Frame1" Then
For Each oCtl In Lbl.Parent.Controls
If TypeOf oCtl Is Label Then
If oCtl.Tag <> "" Then
oCtl.BackColor = Val(oCtl.Tag)
End If
End If
Next
Lbl.BackColor = ACTIVE_COLOR
bClicked = True
End If
End Sub
Private Sub Lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim tCurPos As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
On Error Resume Next
With Lbl
If .BackColor = ACTIVE_COLOR Then Exit Sub
If .Parent.Tag = "" Then
If .Tag = "" Then Lbl.Tag = .BackColor
If .BackColor <> HOVER_COLOR Then .BackColor = HOVER_COLOR
.Parent.Tag = "looping"
Do
GetCursorPos tCurPos
#If Win64 Then
Dim Ptr As LongPtr
CopyMemory Ptr, tCurPos, LenB(tCurPos)
Call AccessibleObjectFromPoint(Ptr, oIA, vKid)
#Else
Call AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
#End If
DoEvents
Loop Until oIA.accName(CHILDID_SELF) <> .Caption Or bClicked
bClicked = False
Call OnMouseLeave(Lbl)
End If
End With
End Sub
Private Sub OnMouseLeave(ByVal Button As Label)
Button.Parent.Tag = ""
If Button.BackColor <> ACTIVE_COLOR Then
Button.BackColor = Button.Tag
End If
'other code goes here..
End Sub
