Fire events when key is released VBA - vba

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

Related

Is there a way to check if a PowerPoint is being presented using VBA code?

I am working on a VBA Module for an interactive PowerPoint. Specifically, I would like a text box to display the current time and update every second (like a live clock) using VBA. I have created and implemented the clock just fine except the clock does not exit its loop when the presentation ends and will continue to update the text box while editing the PowerPoint outside of the presentation mode. I have tried using the sub App_SlideShowEnd(ByVal Pres As Presentation) ( https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshowend), sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow) (https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshownextslide), and even an add-in called AutoEvents (usage shown here http://www.mvps.org/skp/autoevents.htm#Use) to catch the end of the slide show, but to no avail.
So my question to you is: Is there a way to check if the current PowerPoint is actively presenting? If so, I could use it to check if the PowerPoint is presenting instead of checking my boolean variable clockstate that allows the clock to count or not. Here is the implementation of just the clock sub:
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Here is the implementation of just the App_SlideShowEnd event:
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
And here is all of my code all together if you want to see it in one piece:
Option Explicit
Dim indexA As Integer 'this variable contains the slide that Injury_Time is found on for use in the auto next slide event
Dim indexB As Integer 'this varaible contains the slide that Defect_Time is found on for use in the auto next slide event
Dim clockstate As Boolean 'this varaible dictates wether or not the clock is on and counting to save memory/processing resources.
Dim Injury As Shape 'this variable is used to reference the textbox that gets changed by the macro
Dim Defect As Shape 'this varaible is used to reference the other textbox that gets changed by the macro
Dim entryA As Date 'this holds the contents of the first entrybox on the config form so the form can be unloaded without losing the entries
Dim entryB As Date 'this holds the contents of the second entrybox on the config form so the form can be unloaded without losing the entries
Dim daysA As String 'this holds the number of days since last injury for auto-setting the textboxes in the config form
Dim daysB As String 'this holds the number of days since last defect for auto-setting the textboxes in the config form
Sub Auto_Open() 'runs on startup from AutoEvents add-in. runs the find function to locate the Macro-edited slides, then opens the config form
'declare clockstate as false until it is true and turned on
clockstate = False
'assign values the global Injury and Defect variables
Call Find
'try calling the name fields (need to assign it to a variable to try it). If Injury and Defect were found, then nothing happens. Otherwise it moves the the Not_Found label
On Error GoTo Not_Found
'setup daysA and daysB
daysA = Left(Injury.TextFrame.TextRange.text, Len(Injury.TextFrame.TextRange.text) - 8)
daysB = Left(Defect.TextFrame.TextRange.text, Len(Defect.TextFrame.TextRange.text) - 8)
'assign default values to the Config boxes
Config.TextBox1.Value = Date - daysA
Config.TextBox2.Value = Date - daysB
'show config
Config.Show
Exit Sub
'error messaging for if the textbox assignments were not found
Not_Found:
MsgBox "Error: The Macro-edited textbox(es) were not found! This is likely due to the most recent editing preformed on this Powerpoint. Please revert the changes, create a new textbox with the name """"Injury_Time"""" or """"Defect_time"""" (whichever is missing), contact your local VBA expert, or read the Documentation for help."
End Sub
Sub Find() 'locates the textbox that the global variables Injury and Defect are supposed to represent
'use a 2D for loop to iterate through each slide and it's shapes
Dim i As Integer
Dim j As Integer
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Injury_Time") = 0 Then
Set Injury = ActivePresentation.Slides(i).Shapes(j)
indexA = i
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Defect_Time") = 0 Then
Set Defect = ActivePresentation.Slides(i).Shapes(j)
indexB = i
End If
Next j
Next i
End Sub
Sub Save() 'saves the contents of the config form to the global varaibles entryA and entry B then unloads the form to save memory
'save the contents of the config form so we can unload it to save memory
entryA = Config.TextBox1.Value
entryB = Config.TextBox2.Value
'unload the form to save memory
Unload Config
End Sub
Sub Auto_ShowBegin() 'starts the clock for the timers when the show starts
'start clock
clockstate = True
Call clock
End Sub
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
Sub Auto_Close() 'this is run by the AutoEvents add-in. It displays an informative message when the powerpoint is closed with instructions for the next time the powerpoint is opened
'prevent clock from running after program is closed
clockstate = False
'message to configure the powerpoint when it is opened again
MsgBox "Thank you for using this Macro-Enabled PowerPoint!" & vbCrLf & vbCrLf & "Next time the PowerPoint is opened, you will be asked to re-enter the dates of the most recent injury and quality defect."
End Sub
Thank you for your help and May the 4th be with you!
I think your 'Wait' function is not reliable. The 'for' loop may not end in some case.
To control the clock ticking event, you can make use of Windows 'Timer' API. Though the Timer API is not that reliable or easy to use, it can be controlled and tailored.
The sample code goes like this:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public TimerID As LongPtr
#Else
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
Public TimerID As Long
#End If
Const Default As Integer = 1 'the target slide where the 'Clock' textbox exists
Dim Pause As Boolean
Sub StartNow()
StartTimer
End Sub
Sub StopNow()
StopTimer
End Sub
'main timer process : this sub-routine CANNOT be interrupted by any error or itself
Sub myTimer()
On Error Resume Next
If Pause Then Exit Sub
'the Default slide should have a textbox called 'Clock'
ActivePresentation.Slides(Default). _
Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
End Sub
Function StartTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer) ' 1000 = 1sec
End If
End Function
Function StopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
End Function
'the timer can be paused, if this macro is added to the 'Clock' textbox as an action trigger
Sub PauseTimer()
Pause = Not Pause
End Sub
'the timer must be stopped after finishing the show
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)
StopTimer
End Sub
'To start the clock automactically
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.View.CurrentShowPosition = Default Then
StartTimer
Else
StopTimer
End If
End Sub
Requirement: A Textbox called 'Clock' should exist on Slide #1.
Warning:
The Timer must be stopped after closing the show. Otherwise, Powerpoint application might crash!
'myTimer' should not contain any error or call itself recursively.

VBA F9 Button recognized left mouse button not recognized

The VBA code "WaitUntilF9Key" detects the "F9" key pressed when its pressed and not until it is pressed. The "WaitUntilLButton" fires right away, not when the left keypad button is pressed. Why would this be? Tkx
Option Compare Database
Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Const VK_LBUTTON = &H1
Public Const VK_RBUTTON = &H2
Private Const VK_F9 = &H78
Sub WaitUntilF9Key()
Do Until GetAsyncKeyState(VK_F9)
DoEvents
Loop
MsgBox ("Ta Da")
End Sub
Sub WaitUntilLButton()
Do Until GetAsyncKeyState(VK_LBUTTON)
DoEvents
Loop
MsgBox ("Ta Da")
End Sub
GetAsyncKeyState returns a byte, not a boolean. You need to 'And' it with the bit you're looking for to get a meaningful result.
In your case, the bit you want is &H8000. From the microsoft docs for GetAsyncKeyState:
If the &H8000 bit of the return value is set, the key has been pressed at least once since the last time the thread called GetAsyncKeyState
Sub WaitUntilF9Key()
Do Until GetAsyncKeyState(VK_F9) And &H8000
DoEvents
Loop
MsgBox ("Ta Da")
End Sub
Sub WaitUntilLButton()
Do Until GetAsyncKeyState(VK_LBUTTON) And &H8000
DoEvents
Loop
MsgBox ("Ta Da")
End Sub
That said, like others have mentioned, busy-looping like this should usually be avoided if possible

How do I check if a value a user is entering in Textbox is a numeric double?

I am trying to check if a user enters a number value in a textbox, decimal places accepted. Any help is highly appreciated.
Private Sub textbox1_AfterUpdate()
If IsNumeric(textbox1.Value) = False Then
Me!textbox1.Undo
MsgBox "only numbers are allowed"
Exit Sub
End If
Exit Sub
using BeforeUpdate event:
Private Sub textbox1_BeforeUpdate(Cancel As Integer)
If IsNumeric(textbox1.Value) = False Then
MsgBox "only numbers are allowed"
Me!textbox1.Undo
Cancel = True
Exit Sub
End If
Exit Sub
My current code does not execute at all. I have also tried it in the textbox1_BeforeUpdate event. Please see code.
New Code:
Public Function IsValidKeyAscii(ByVal keyAscii As Integer, ByVal value As
String) As Boolean
IsValidKeyAscii = (keyAscii = vbKeyDot And InStr(1, value, Chr$(vbKeyDot)) =
0) Or (keyAscii >= vbKey0 And keyAscii <= vbKey9)
End Function
Private Sub textbox1_KeyDown(KeyCode As Integer, Shift As Integer)
If Not IsValidKeyAscii(KeyCode, textbox1.value) Then KeyCode = 0
End Sub
You shouldn't be using VBA for this task at all.
Just set the field format property to General number. That's the built-in way to ensure users can only enter numbers in a field.
Write a validator function (could be in its own KeyInputValidator class or module), so you can reuse this logic everywhere you need it, instead of copy/pasting it for every numeric textbox you need:
Option Explicit
Private Const vbKeyDot As Integer = 46
'#Description("returns true if specified keyAscii is a number, or if it's a dot and value doesn't already contain one")
Public Function IsValidKeyAscii(ByVal keyAscii As Integer, ByVal value As String) As Boolean
IsValidKeyAscii = (keyAscii = vbKeyDot And InStr(1, value, Chr$(vbKeyDot)) = 0) Or (keyAscii >= vbKey0 And keyAscii <= vbKey9)
End Function
Then use it in the textboxes' KeyPress event handler (assuming this is a MSForms textbox control) to determine whether or not to accept the input - since the event provides a MSForms.ReturnInteger object, that object's Value property can be set to 0 to "swallow" a keypress:
Private Sub TextBox1_KeyPress(ByVal keyAscii As MSForms.ReturnInteger)
If Not IsValidKeyAscii(keyAscii.Value, TextBox1.value) Then keyAscii.Value = 0
End Sub
That way you don't need to undo any inputs, or pop any annoying warning or message boxes: the value in the field is guaranteed to be a valid numeric value!
EDIT the above event handler signature is for a MSForms control. Looks like Access uses a different interface:
Private Sub TextBox1_KeyDown(KeyCode As Integer, Shift As Integer)
Here the KeyCode is passed ByRef, so you can alter it directly. In other words, this becomes the logic:
If Not IsValidKeyAscii(KeyCode, TextBox1.value) Then KeyCode = 0
You can try using the lost focus event:
Private Sub TextBox1_LostFocus()
Dim blnNumber As Boolean
Dim strNumber As String
strNumber = TextBox1.Value
blnNumber = IsNumeric(strNumber)
If Not blnNumber Then
Me!TextBox1.Undo
MsgBox "only numbers are allowed"
Else
'And, if you want to force a decimal.
If InStr(strNumber, ".") < 1 Then
Me!TextBox1.Undo
MsgBox "only doubles are allowed"
End If
End If
End Sub
Also, check the Textbox1 element that you have listed in access. Is it's name TextBox1? or something else?
For example, in excel it is represented like the following: =EMBED("Forms.TextBox.1","") even though the name that the code references is TextBox1.

Create Tooltip using MouseMove on ActiveX Checkbox

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

Create Formula in a TextBox using Excel VBA

Does anyone know if it's possible to have a textbox in a userform in Excel 2010 work like the formula editor?
In other words when the userform is up and the textbox is the focused control allow me to type say
=AND(
Then click cell D2 and have the text box then be
=AND($D$2
Then type a =
=AND($D$2=
Then click cell E2
=AND($D$2=$E$2
Then type )
=AND($D$2=$E$2)
I've played around with the RefEdit control but it just overwrites any custom text as soon as a range is selected on the sheet, I basically need it to append to the text box when I click on a range.
Put this code in the ThisWorkbook module:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo EndOfSub
If UserForm1.ActiveControl.Name = "TextBox1" Then
UserForm1.TextBox1.Value = UserForm1.TextBox1.Value & Target.Address
End If
EndOfSub:
End Sub
This way when your userform is loaded (UserForm1 here) and your textbox is active (TextBox1 here), the address of the selection is appended to it. If you need to add the worksheet's name too, change the 3rd line above:
UserForm1.TextBox1.Value = UserForm1.TextBox1.Value & sh.Name & "!" & Target.Address
If you need to use it on only one sheet, put the code to that Sheet's code instead of the ThisWorkbook's code.
It is not as sophisticated as the formula editor, as it always appends the selection. (Changing the just inserted reference is doable too if you need it, just takes a bit more checking.)
Do note that putting code into the ThisWorkbook's SheetChange method takes its toll: you will not be able to use Undo in this workbook.
A bit more elegant way to check if a Userform is loaded can be found (here)[http://www.ozgrid.com/forum/showthread.php?t=152892]. You can use this instead of the On Error Goto part.
Yes, this is possible in a TextBox, but the problem you have is that you'll need to show the UserForm modelessly because you need to select cells in a worksheet while the Userform is on show. If you want to do exactly as you describe, ie the very next keystroke is '=', then you will need to re-activate the UserForm otherwise you'll simply add an '=' into your selected cell.
I believe the Show command won't re-activate a modeless UserForm that is already on show and I'm not aware of an Activate command for a UserForm. Others may well know of one, but I'd use a couple of APIs to do the job. So the code in your Userform could be as follows (you may need to adjust the API declarations if you have Win64 and/or VB7 https://msdn.microsoft.com/en-us/library/office/ee691831(v=office.14).aspx):
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetForegroundWindow" _
(ByVal hwnd As Long) As Long
Private mHwnd As Long
Private mTextBoxHasFocus As Boolean
Public Property Get TextBoxHasFocus()
TextBoxHasFocus = mTextBoxHasFocus
End Property
Public Sub AppendText(appendedText As String)
'Add the text to textbox
TextBox1.Text = TextBox1.Text & appendedText
'Activate this userform window
SetFocusAPI mHwnd
'API doesn't trigger UserForm_Activate event so call it
Me.ActivateByCode
End Sub
Private Sub TextBox1_Enter()
mTextBoxHasFocus = True
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
mTextBoxHasFocus = False
End Sub
Public Sub ActivateByCode()
'Set focus on any another control then back to textbox
btnSave.SetFocus
'Set cursor at end of text
TextBox1.SelStart = Len(TextBox1.Text)
TextBox1.SelLength = 0
TextBox1.SetFocus
End Sub
Private Sub UserForm_Initialize()
'Acquire the handle for this window
mHwnd = FindWindow("ThunderDFrame", Me.Caption)
End Sub
You'd then call the AppendText routine from a WorkSheet_Change event or, as in this case, a Workbook_SheetSelectionChange event (which caters for selections of a cell in any WorkSheet):
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If UserForm1.TextBoxHasFocus Then
UserForm1.AppendText Target.Address
'Uncomment the line below if you want sheet name as well as address
'UserForm1.AppendText Sh.Name & "!" & Target.Address
End If
End Sub
And remember to show your UserForm modelessly:
UserForm1.Show False
If you want to cursor to be in the TextBox when the UserForm opens, then add this line too:
UserForm1.ActivateByCode
(Posted on behalf of the question author).
Checking for the selection changed was what I was missing. I was SO focused on trying to make the UserForm behave I completely spaced on ALL the other events Excel has to work with!
In the end I went with a check in the SelectionChanged sub to see if a simpler UserForm (minimal size with textbox and restore button) was visible and the textbox was active.
I added a little more logic to handle inserting into the cursor location of the textbox as well as straight appending. Might add some support for arrow keys in the future but I have the original functionality I set out to have.
Microsoft, if you're listening, would it have been possible to give us a RefEdit control that looks and behaves like the one built into Excel? Just a thought.