I am trying to get a tooltip to display over an ActiveX Checkbox on my excel spreadsheet.
The below code does display and hide the tooltip but not as expected. If you move the mouse over the checkbox too quickly, the tooltip (label) will remain on the sheet.
Private Sub chkPrice_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With sht
If .lblTooltip.Visible = False Then
.lblTooltip.Visible = True
ElseIf .lblTooltip.Visible = True Then
.lblTooltip.Visible = False
End If
End With
To make the above code work, if there is something along the lines of:
If mousehovers for 1 second Then display the tooltip
Is there a way to check for amount of time the mouse remains on a control?
Is there another way to do this?
There is something pretty tricky that you could do for that, so below you can find a starting point for your specific answer.
Direct answer to the question
On top of your module, you declare the Microsoft API getting the mouse coordinates:
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Note: if you're using a 32-bit system, remove the PtrSafe keyword from the declaration.
Also, on top of the module, you add this type:
Type POINTAPI
Xcoord As Long
Ycoord As Long
End Type
Hence, inside your macro chkPrice_MouseMove, you do something like this:
When the macro is triggered, get the mouse coordinates
Wait very shortly, say half second
Hence, get again the mouse coordinates. If they are the same than before, it means the user is keeping the mouse on the same point so you can trigger the event.
In code:
Private Sub chkPrice_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim llCoordBefore As POINTAPI
Dim llCoordAfter As POINTAPI
GetCursorPos llCoordBefore '<-- get first time
Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now())+0.5)
GetCursorPos llCoordAfter '<-- get second time
If llCoordBefore.Xcoord = llCoordAfter.Xcoord And llCordBefore.Ycoord = llCoordAfter.Ycoord Then '<-- compare
With sht
If .lblTooltip.Visible = False Then
.lblTooltip.Visible = True
ElseIf .lblTooltip.Visible = True Then
.lblTooltip.Visible = False
End If
End With
End If
Why I wouldn't use this
I think that your best shot is to put the ActiveX control in a place where the user doesn't hover by mistake.
Your code, on mouse hover, says that:
1) If the tooltip is not visible, then make it visible
2) If the tooltip is visible, then hide it
If the user passes quickly on the control, and the tooltip is hidden, it's expected that it will show up and don't hide. The user should pass back on the control to get it hidden again.
In any case, here are some reasons why the above method you thought about is not my recommendation:
The application will wait for X seconds. If the user hovers by mistake, he will get his Excel waiting for X seconds before he can take control again. It might be annoying in terms of UX.
The API gets the coordinates in a very sensitive way. You will need to implement an approximation (in my example, I'm proceeding only if the coordinates are exactly the same before and after hover; however, in real life, you will need to leave some margin cause the mouse might slightly move between the first and the second get of the coordinates).
Use the Application.OnTime to hide the label 1 second after the mouse moves over the checkbox.
Public Code Module
Public TootTipVisible As Boolean
Public CheckBoxHasFocus As Boolean
Public Sub ShowTootTip()
Application.Caption = Now 'TootTipVisible & "," & CheckBoxHasFocus
If Not TootTipVisible And Not CheckBoxHasFocus Then
TootTipVisible = True
Sheet1.sht.Visible = True
Application.OnTime Now + TimeValue("00:00:01"), "HideTootTip"
End If
End Sub
Public Sub HideTootTip()
TootTipVisible = False
Sheet1.sht.Visible = False
End Sub
Worksheet Code Mode
Private Sub chkPrice_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If X > 0 And X < chkPrice.Top - chkPrice.Height Then
ShowTootTip
CheckBoxHasFocus = True
Else
CheckBoxHasFocus = False
End If
End Sub
Related
I have a couple user forms in VBA, id like to add a feature that when a user first clicks on a textbox (changes the focus to it), any text inside gets selected. I've seen this feature in some accounting applications and in your web browser when you first click the URL bar. Its essentially meant so that users can immediately overwrite a text field. Was wondering how I might do the same in VBA, but I'm still a novice. I looked through a couple sub triggers(dont know the correct term) but haven't seen any. I found one for when you click the text box but I don't want the text constantly being selected every time I click the field.
Thanks.
put this in your textbox event
Dim checked As Boolean
Private Sub TextBox1_Change()
If checked = True Then
TextBox1.SelStart = 0
TextBox1.SelLength = 0
checked = True
End If
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
checked = False
End Sub
Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If checked = False Then
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1)
checked = True
End If
End Sub
once you click your textbox, it will hightlight the text, if you click the text, it will unhightlight and allow you to modified the text. if you click outside that textbox and click back inside that will rehighlight the whole text.
I have this code to detect when Enter is pressed
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Const VK_RETURN As Integer = &HD
And I use this function in a macro like this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If GetKeyState(VK_RETURN) < 0 Then Enter = True Else Enter = False
If Enter = True Then
Call IncreaseValue
End If
End Sub
This however is called multiple times when the Enter key is held down.
Is there a way to only call this function once every time the enter key is pressed?
Additional info just in case:
Why I need it is because I have a dataentry sheet, which works as a form - every time the enter key is pressed, it increases a cell value by 1, which is used to lookup values. But holding down enter will skip through records.
Of course there's! All you need is to track Enter key toggling (note return values).
The main idea behind that is to track the low-order bit (toggle/untoggle), and whenever it changes and the high-order bit is 1 (pressed) - we're free to increase what we desire.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static StatePreservedResponse As Long
Dim StateResponse As Long
StateResponse = GetKeyState(VK_RETURN)
If StateResponse < 0 And StateResponse <> StatePreservedResponse Then
Call IncreaseValue
End If
StatePreservedResponse = StateResponse
End Sub
Is there any way to keep Doing something while a key (mouse key) is kept pressed in vba?
%' As if there were for example a MouseLeftClicked vba function
Do While MouseLeftClicked
Sheet1.Shapes("Picture 1").Rotation = Sheet1.Shapes("Picture 1").Rotation + 15
DoEvents
The short answer is yes, but you'll need to capture the mouse clicks in a UserForm as below:
In your UserForm
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
booKeyPressed = True
RotateIt
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
booKeyPressed = False
End Sub
In a Module
Public booKeyPressed As Boolean
Function RotateIt()
If Not booKeyPressed Then Exit Function
Application.OnTime Now + TimeValue("00:00:01"), "RotateIt"
Sheet1.Shapes("Picture 1").Rotation = Sheet1.Shapes("Picture 1").Rotation + 15
DoEvents
End Function
The above code will rotate your picture every 1 second so long as the mouse is clicked on your Userform. You can change this to be a specific control and you can also change the time interval should you need to.
There's no way I know of to capture the MouseClick event on a worksheet, but you could link it to a worksheet event if that better suits your needs.
Your question mentions key press, but your sample code mentions mouse. You can easily adapt to which ever you need because both are available as Userform events
I was using the following code to select text inside a text box of a userform everytime I clicked on it, however I have almost 40 text boxes and I would like to know if there's a way to write a single code for all of them instead of copying and pasting this same piece of code 40 times.
Private Sub textbox1_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer,ByVal X As Single, ByVal y As Single)
With Me.textbox1
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
There are ways to write a single instance that will run for them all.
You will need to add a line of code for the MouseDown event for each textbox that will call the single instance of the code.
For example: -
Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
SelectText
End Sub
Then create a procedure that works on the ActiveControl: -
Private Sub SelectText()
With ActiveControl
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
I have a powerpoint presentation that contains animations that show & hide shapes. In addition, there I have VBA scripts that run that will resize some of the same shapes. Whenever the VBA script is running, all of the shapes that were hidden using an animation appear and remain visible until the script finishes.
I could always change all of my animations to use VBA scripts instead to set the .Visible attribute of the shapes but this seems cumbersome and consumes a lot of code.
Is there any way to have VBA script an animations work together?
Thanks in advance
Here is the code:
Private Type MyIntegerPoint
x As Long
y As Long
End Type
Private Type MySinglePoint
x As Single
y As Single
End Type
Private Type MyRect
top As Single
left As Single
bottom As Single
right As Single
End Type
Option Explicit
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As MyIntegerPoint) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "User32" (ByVal whichButton As Integer) As Integer
Public MousePt As MySinglePoint
Public StartPt As MySinglePoint
Public ShapeOrigCoord As MySinglePoint
Public InDrag As Boolean
Public Sub VerticalDragShape(ByRef sh As Shape)
If Not InDrag Then
InDrag = True
End If
' initialize drag variables
InitDragVars sh
ActivePresentation.SlideShowWindow.View.State = ppSlideShowPaused
While InDrag
GetScaledMousePt
DoEvents
Dim keyState As Integer
keyState = GetAsyncKeyState(1)
If keyState < 0 Then
InDrag = False
Else
With ActivePresentation.Windows(1).View.Slide
.Shapes("Shape1").top = MousePt.y
.Shapes("Shape1").left = MousePt.x
End With
End If
Wend
ActivePresentation.SlideShowWindow.View.State = ppSlideShowRunning
End Sub
Private Sub GetScaledMousePt()
Dim mPt As MyIntegerPoint
'Get the current raw mouse point
GetCursorPos mPt
'Convert it to point coordinates
MousePt.x = MouseXCoordToPoints(mPt.x)
MousePt.y = MouseYCoordToPoints(mPt.y)
End Sub
' converts an x screen coordinate into document window coordinates
' first, convert the screen pixels into slide show window coordinates
' second, convert slide show window coordinates to document window coordinates
Public Function MouseXCoordToPoints(x As Long) As Single
Dim slideWidth As Single
Dim screenWidth As Single
Dim fx As Single
fx = x
slideWidth = ActivePresentation.PageSetup.slideWidth
screenWidth = GetSystemMetrics(0)
MouseXCoordToPoints = fx * slideWidth / screenWidth
End Function
Public Function MouseYCoordToPoints(y As Long) As Single
' TRIAL 3
Dim slideHeight As Single
Dim screenHeight As Single
Dim fy As Single
fy = y
slideHeight = ActivePresentation.PageSetup.slideHeight
screenHeight = GetSystemMetrics(1)
MouseYCoordToPoints = fy * slideHeight / screenHeight
End Function
Private Sub InitDragVars(ByRef sh As Shape)
GetScaledMousePt ' scale current mouse point
StartPt = MousePt ' save start mouse point
ShapeOrigCoord.x = sh.left ' capture left coord of shape
ShapeOrigCoord.y = sh.top ' capture top coord of shape
End Sub
To exhibit the problem, create a single slide presentation that contains two shapes. Name the shapes in the presentation Shape1 & Shape2. Create an animation that hides Shape2 when placed in presentation mode. Insert an action on Shape1 to run VerticalDragShape when clicked on with the mouse. When you run the presentation, Shape2 should be hidden. Clicking (and releasing) the mouse on Shape1 should cause it to move with the mouse until you click again. However, when moving Shape1, Shape2 becomes visible again until the move operation is complete when it becomes hidden.