Switch the keyboard language with VBA - vba

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

Related

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

Refresh built-in Ribbon button after Options.DefaultHighlightColorIndex change and avoid exiting "Text Highlight Color"

What I'm trying to get working:
activate the Text Highlight Color command via a keybinding (not the problem)
cycle through 5 of the Default Text Highlight Colors via the same keybinding (or just highlighting the selection, depending on selection.type checked outside the function below)
showing the current Color in the corresponding button (built-in ribbon)
Where I'm stuck:
Sub cycleThroughSomeDefaultHighlightColorIndexOptions()
Dim zeNewColor As Long
Select Case Options.DefaultHighlightColorIndex
Case wdYellow: zeNewColor = wdBrightGreen
Case wdBrightGreen: zeNewColor = wdTurquoise
Case wdTurquoise: zeNewColor = wdPink
Case wdBlue: zeNewColor = wdRed
Case wdRed: zeNewColor = wdYellow
Case Else: zeNewColor = wdYellow
End Select
Application.Options.DefaultHighlightColorIndex = zeNewColor
End Sub
doesn't throw any error, does change the Application.Options.DefaultHighlightColorIndex,
but doesn't update/show the newly set color on the corresponding (built-in ribbon home tab) button
and just exits out of the Text Highlight Color mode.
Is there a possibility to keep it going?
If it needs to be started again: is there a better way than
dirty/interfering sendKeys to call commands like Text Highlight
Color?
Update 2019-04-03:
In the mean time i found where the IRibbonUI.InvalidateControlMso ControlIDs are listed: Office 2016 Help Files: Office Fluent User Interface Control Identifiers
So after creating a hidden custom ribbon and getting a handle for it on onLoad i could zeWdRibbon.InvalidateControlMso "TextHighlightColorPicker" without any raised error.
But it also doesn't change anything.
Is it possible, that Microsoft just getImages the default imageMso "TextHighlightColorPicker" (yellow) without checking for Application.Options.DefaultHighlightColorIndex , or am I missing something?
I do something like that, each time gRibbon.Invalidate
#If VBA7 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#Else
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#End If
Public gRibbon As IRibbonUI
#If VBA7 Then
Function GetRibbon(ByVal lRibbonPointer As LongPtr) As Object
#Else
Function GetRibbon(ByVal lRibbonPointer As Long) As Object
#End If
Dim objRibbon As Object
Call CopyMemory(objRibbon, lRibbonPointer, LenB(lRibbonPointer))
Set GetRibbon = objRibbon
Set objRibbon = Nothing
End Function
Public Sub OnRibbonLoad(ribbon As IRibbonUI)
Set gRibbon = ribbon
'SAVE SETTINGS TO REGISTRY
SaveSetting "POP", "RIBBON", "ribbonPointer", ObjPtr(gRibbon)
End Sub
Public Sub OnActionButton(control As IRibbonControl)
If gRibbon Is Nothing Then
Set gRibbon = GetRibbon(GetSetting("POP", "RIBBON", "ribbonPointer"))
End If
On Error Resume Next
gRibbon.Invalidate
On Error GoTo 0
End Sub

Getting an application_calculate event to run

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.

Programmatically dismiss a MsgBox

I have a master macro in an Excel file, 'file A' that opens another Excel file, 'file B'. On open, an add-in imports data into 'file B'. I would like to close 'file B' once the add-in is finished importing, and I'm looking for the best way to do that.
I've written the code to open 'file B' (which triggers the add-in automatically) and to close the file, but when the add-in is finished, it opens a MsgBox to notify the user. I'm trying to completely automate an internal process, so dismissing the MsgBox programmatically would be ideal.
Is it possible to dismiss a MsgBox through VBA? I'm aware that I can create timed MsgBoxes in VBA but I'm not creating this MsgBox (the add-in is); I just want to dismiss it. I'm open to creating a Word file and calling a macro from that if required, but would prefer not to use SendKeys.
Since the "add-in" and Excel/VBA run in the same context, we cannot launch it and monitor its message-box within the same VBA application, because each VBA application is a single-threaded process. Fortunately however, there is a solution that can exploit the fact that different VBA applications run in different contexts, so they can run in parallel.
My suggested solution is to create a MS-Word document that is dedicated to monitoring and closing that message box. We need this in Word (or any other office application) in order to make the monitoring code and the addin's code run in parallel, in different contexts.
1- create a Word macro-enable document, named mboxKiller.docm and place it in some folder; i.e. C:\SO in my example. place this code in ThisDocument and save:
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Sub WaitAndKillWindow()
On Error Resume Next
Dim h As Long: h = FindWindow(vbNullString, "Microsoft Excel")
If h <> 0 Then SendMessage h, 16, 0, 0 ' <-- WM_Close
Application.OnTime Now + TimeSerial(0, 0, 1), "WaitAndKillWindow"
End Sub
Private Sub Document_Open()
WaitAndKillWindow
End Sub
2- In the Excel workbook's VBA, create a class module, named mboxKiller with this code:
Private killerDoc As Object
Private Sub Class_Initialize()
On Error Resume Next
Set killerDoc = CreateObject("Word.Application").Documents.Open(Filename:="C:\SO\mboxKiller.docm", ReadOnly:=True)
If Err.Number <> 0 Then
If Not killerDoc Is Nothing Then killerDoc.Close False
Set killerDoc = Nothing
MsgBox "could not lauch The mboxKiller killer. The message-box shall be closed manuallt by the user."
End If
End Sub
Private Sub Class_Terminate()
On Error Resume Next
If Not killerDoc Is Nothing Then killerDoc.Application.Quit False
End Sub
3- Testing and Usage. In a normal class Module, place the following code and test the procedure
Sub Test() ' <-- run this for testing after finishing the setup
Dim killer: Set killer = New mboxKiller
simulateAddin
simulateAddin
simulateAddin
End Sub
' Procedure supposed to do some calculation then display a message box
Private Sub simulateAddin()
Dim i As Long
For i = 0 To 1000: DoEvents: Next ' simulates some calculations
MsgBox "This is a message box to simulate the message box of the addin." & VbCrLf & _
"It will be automatically closed by the Word app mboxKiller"
End Sub
VBA also has the ability to temporarily dismiss alerts.
Application.DisplayAlerts = False
'while you run your code here, no alerts will be displayed
Application.DisplayAlerts = True

SendKeys is messing with my NumLock key via VBA code in Access form

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