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
Related
I have a multi-lingual database and am trying to make it so that the correct language is typed in the correct fields by using the "on current" event. Presently, the users use Alt+Shift until the language appears in the task bar. The languages are English, Hebrew, Arabic & German. The users are fluent typists in the languages. Constantly Alt+Shifting to select the correct language for each field slows down data entry dramatically.
I have searched the internet for VBA code to do this. The closest I can find is "Sendkeys" which works in part by turning off & on Scroll Lock for autohotkeys which is only used for Hebrew vowel pointing, but I am unable to figure out how to select the keyboard language via VBA code.
Sample code for the Hebrew Name search button:
Private Sub btnHebCustomerSearch()
SendKeys "{scrolllock}", True
Me.FilterOn = False
DoCmd.GoToRecord , "", acFirst
DoCmd.RunCommand acCmdFind
On Error Resume Next
End Sub
I found a ton of web resources on this topic with Bing search "Access VBA switch keyboard language".
Use API function:
Private Declare PtrSafe Function ActivateKeyboardLayout Lib _
"user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long
'define your desired keyboardlanguage
'find your desired language at http://www.trigeminal.com/frmrpt2dap.asp
Private Const MKD = 1071 'macedonian keyboard language layout
Private Const eng = 1033 'english(united states)keyboard language layout
Private Sub A_Enter()
Call ActivateKeyboardLayout(MKD, 0)
End Sub
Private Sub A_Exit(Cancel As Integer)
Call ActivateKeyboardLayout(eng, 0)
End Sub
Untested, code from https://www.access-programmers.co.uk/forums/threads/any-idea-how-to-change-system-keyboard-lenguage-with-vba.193030/
Probably should declare the API function as Public and place it in a general module instead of behind a form. The Const declarations are not needed if intrinsic language code constants are used. View a list in VBA object browser. Type MsoLanguageID in the Search box and click Search button. https://learn.microsoft.com/en-us/office/vba/api/access.application.languagesettings
This is the code that finally worked, thank you June7 for your help, you led me in the right direction:
Option Compare Database
Private Declare PtrSafe Function ActivateKeyboardLayout Lib "user32.dll" (ByVal mylanguage As Long, flag As Boolean) As Long
Private Const Heb = 1037
Private Const Eng = 1033
Private Const Ger = 1031
Private Const Grk = 1032
Private Const Yid = 1085
Private Sub Text2_Enter() 'Hebrew Keyboard Layout
Call ActivateKeyboardLayout(Heb, True)
End Sub
Private Sub Text2_Exit(Cancel As Integer)
Call ActivateKeyboardLayout(Eng, True)
End Sub
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.
We have an AddIn to get data from Sun Financials. It uses Sendkeys so we get the problem of NumLock randomly turning off.
Data is retrieved from Sun when the worksheet/book is recalculated.
I have VBA to turn NumLock back on if it's turned off, but how can I get it to run in any workbook I have open?
I tried putting an Application_Calculate in Personal.xlsb ThisWorkbook but it doesn't run.
How can I get it to run?
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Sub Application_Calculate(ByVal Sh As Object)
If CBool(GetKeyState(vbKeyNumlock) And 1) = False Then SendKeys "{NUMLOCK}", True
End Sub
PS Putting it into the ThisWorkbook outside of personal.xlsb isn't an option, there's thousands of files it needs to work on plus they don't like workbooks with VBA in (company policy).
Got this working, by placing the following code into ThisWorkbook in Personal.xlsb
Bizarre. or not. It now works, but it's not worked until everything was correct. Here's what I've got:-
Code:
Option Explicit
Public WithEvents App As Application
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Set App = Application
If CBool(GetKeyState(vbKeyNumlock) And 1) = False Then SendKeys "{NUMLOCK}", True
End Sub
Private Sub Workbook_Open()
Set App = Application
End Sub
Private Sub App_SheetCalculate(ByVal Sh As Object)
Set App = Application
End Sub
So, when I hit F9 or change a cell, NumLock turns back on.
One stightly bizarre but useful feature is that the Undo list is preserved! I was expecting to have to restore it once I'd got the Numlock bit working, but as the VBA is only doing a Sendkey and not flagging anything as changing from within the VBA Excel miraculously isn't emptying the Undo or Redo list. So the maxim that VBA always empties the Undo/Redo lists isn't true.
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
I have the following code for an Access form. It appears as if the SendKeys is messing with my NumLock key by toggling it on and off as I open and close the form.
For perfectly valid reasons which I don't want to get into, I really do not want to completely hide the ribbon (I want the pull down menus still accessible) so the DoCmd.ShowToolbar command is not my preferred way of doing it.
Does anyone have any suggestions as to how I can modify the code below to accomplish what I want using the SendKeys command?
Using Access 2007 so the command
CommandBars.ExecuteMso "MinimizeRibbon"
is not available to me.
By the way, database will be distributed so solution must be contained within database.
Private Sub Form_Close()
' Unhide navigation pane
DoCmd.NavigateTo "acNavigationCategoryObjectType"
DoCmd.Maximize
' Maximize the ribbon
RibbonState = (CommandBars("Ribbon").Controls(1).Height < 75)
Select Case RibbonState
Case True
SendKeys "^{F1}", True
Case False
'Do nothing, already maximized
End Select
End Sub
Private Sub Form_Load()
' Hide navigation pane
DoCmd.NavigateTo "acNavigationCategoryObjectType"
DoCmd.Minimize
Debug.Print Application.CommandBars.Item("Ribbon").Height
' Minimize ribbon
RibbonState = (CommandBars("Ribbon").Controls(1).Height < 100)
Select Case RibbonState
Case True
'Do nothing, already minimized
Case False
SendKeys "^{F1}", False
End Select
End Sub
It's a bug in Microsoft VBA. But there is a workaround.
Use F8 to run through the macro and find where it turns it off. It's usually after a SendKeys.
Then add an
Sendkeys "{NUMLOCK}", True after the line to reverse the effect.
If you can't find it, just add it at the end and when it finishes, it will go back. Hopefully, if you add it during the show/hide process, it will work.
This is caused by :
Sendkeys "any key", False
Instead of False as second parameter, use True.
I had similar issue and I found solution on some vba forum. Instead of buggy Sendkeys you can simulate kyes like this.
Option Explicit
'//WIN32API Declare
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'//WIN32API Constant
Public Const KEYEVENTF_EXTENDEDKEY = &H1
Public Const KEYEVENTF_KEYUP = &H2
Public Const VK_CONTROL = &H11
Public Const VK_SHIFT = &H10
Public Const VK_F6 = &H75
Public Function PreviousTab()
keybd_event VK_CONTROL, 0, 0, 0
keybd_event VK_SHIFT, 0, 0, 0
keybd_event VK_F6, 0, 0, 0
keybd_event VK_F6, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_SHIFT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_CONTROL, 0, KEYEVENTF_KEYUP, 0
End Function
Other keys can be found here vba forum
This "previousTab" function just send Control+Shift+F6 key.
The SendKeys() function that is built-in VBA has really a side effect that causes NumLock to be deactivated. But you can use a workaround and call another implementation of the same function that is a part of WSCRIPT component (a part of Windows operating system). The following sample code shows, how a reference to this component can be made and then its method called:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "^g", True
This way, you get the same functionality (calling Ctrl-G keyboard shortcut in the example), but there is no issue with NumLock in this case.
When you do a final sendKeys command in your code, adding in {NUMLOCK} to the statement may do the trick, as noted by RodB and iceBird76. But this is not a good coding practice, and here is why: if anything is different from one time to the next when you run the macro, it may or may not work. I know this because I was experiencing a similar issue myself. When I would do a sendKeys command at the end of my program, sometimes the Num Lock would stay on, but other times it would stay off, just depending on certain variables in my spreadsheet (regardless of whether or not I included {NUMLOCK} in my last SendKeys statement).
I won't get into the details of my own variables, but the point is that to build a program/macro that will keep your Num Lock on consistently, you need to FIRST TEST TO SEE IF THE NUM LOCK IS ON OR OFF, then execute code based upon the present condition.
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const kNumlock = 144
Public Function NumLock() As Boolean
NumLock = KeyState(kNumlock)
If (NumLock = True) Then
MsgBox ("Num lock was off. Will turn back on now...")
SendKeys "{NUMLOCK}", True
Else: MsgBox ("Num Lock stayed on")
End If
End Function
Private Function KeyState(lKey As Long) As Boolean
KeyState = CBool(GetKeyState(lKey))
End Function
Sub myMainMethod()
'do a function here that includes .SendKeys
Call NumLock
End Sub
This sample program will give you a confirmation message as to whether the Num Lock is on or off, and turn it on if it is off.
Right after your SendKeys statement add these 2 lines:
DoEvents
SendKeys "{NUMLOCK}{NUMLOCK}"
This line caused my problem:
Application.SendKeys "%s"
SOLVED by changing to this:
Application.SendKeys "{NUMLOCK}%s"
There's no difference between adding {NUMLOCK} at the beginning or end of the string.
in my case application.senkeys method was creating this problem. so I used
with shell
.sendkeys "{}"
End with
Instead of
with shell
Application.sendkeys ("{}")
End with
64bit VBA version
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const VK_NUMLOCK = &H90
If GetKeyState(VK_NUMLOCK) = 0 Then
SendKeys "{NUMLOCK}", True
End If
You could also check the return value from GetKeyState() before using SendKeys() and restore it by either executing SendKeys "{NUMLOCK}" or not when finished.
SendKeys "^{HOME}", True was turning off the num lock so I just repeated the command and it turns it back on again:
SendKeys "^{HOME}", True
SendKeys "^{HOME}", True
After trying many solutions. The most solid seems to be on the link below. Paste it to a Module.
http://access.mvps.org/access/api/api0046.htm