Замена Sendkeys (API)

По материалам: https://www.access-programmers.co.uk/forums/threads/sendkey.309716/

Option Compare Database
Option Explicit
'modSendkeysReplace_API
'----------------------------------------------------------------------------------------------
'API: Replacement for Sendkeys -  Author : Dev Ashish
'http://access.mvps.org/access/api/api0046.htm
'----------------------------------------------------------------------------------------------
'    The problem with SendKeys causing NumLock to turn off is well known in the Office/VB environment. _
Here's a custom MySendkeys routine which you can use as a replacement instead.
'
'Note: Under most circumstances, SendKeys is not recommended in a production environment. _
    This is because the keystrokes are processed by whichever window is currently active on the desktop. _
    Obviously this will cause unpredictable behavior (to say the least) in case another app receives the focus _
    while your code is processing the Sendkeys statement. _
    If you're unlucky,  the keystrokes when sent to application "y" may cause all documents to be deleted _
    or the hard drive to be formatted. So, simply put, try to avoid Sendkeys at all cost
'
'----------------------------------------------------------------------------------------------
'+
'https://stackoverflow.com/questions/25977933/sendkeys-is-messing-with-my-numlock-key-via-vba-code-in-access-form
'+ !!!
'https://www.access-programmers.co.uk/forums/threads/sendkey.309716/
'----------------------------------------------------------------------------------------------
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' author: Dev Ashish and Arvin Meyer
' modified:
'   arnelgp
'   new VB7 and Win64 support
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'******** Code Start ***********
      ' Declare Type for API call:
      Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128   '  Maintenance string for PSS usage
      End Type

      ' API declarations:
#If VBA7 Then
    Private Declare PtrSafe Function GetVersionEx Lib "kernel32" _
        Alias "GetVersionExA" ( _
            lpVersionInformation As OSVERSIONINFO) As Long
            
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long

    Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
        ByVal bVk As Byte, _
        ByVal bScan As Byte, _
        ByVal dwflags As Long, _
        ByVal dwExtraInfo As LongPtr)

#Else
      Private Declare Function GetVersionEx Lib "kernel32" _
         Alias "GetVersionExA" _
         (lpVersionInformation As OSVERSIONINFO) As Long

      Private Declare Sub keybd_event Lib "user32" _
         (ByVal bVk As Byte, _
          ByVal bScan As Byte, _
          ByVal dwflags As Long, ByVal dwExtraInfo As Long)

      Private Declare Function GetKeyboardState Lib "user32" _
         (pbKeyState As Byte) As Long

      Private Declare Function SetKeyboardState Lib "user32" _
         (lppbKeyState As Byte) As Long
#End If

' Constant declarations:
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1

Function IsCapsLockOn() As Boolean
        Dim o As OSVERSIONINFO

        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)
        IsCapsLockOn = keys(VK_CAPITAL)
End Function

Sub ToggleCapsLock()
        Dim o As OSVERSIONINFO

        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)

        If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then  '=====Win95
        'Toggle capslock
            keys(VK_CAPITAL) = Abs(Not keys(VK_CAPITAL))
            SetKeyboardState keys(0)
        ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then   '=====WinNT
          'Simulate Key Press>
            keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
          'Simulate Key Release
            keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _
               Or KEYEVENTF_KEYUP, 0
        End If
End Sub

Function IsNumLockOn() As Boolean
        Dim o As OSVERSIONINFO
        
        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)
        IsNumLockOn = keys(VK_NUMLOCK)
End Function

Sub ToggleNumLock()
        Dim o As OSVERSIONINFO
                
        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)

          If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then  '=====Win95
                keys(VK_NUMLOCK) = Abs(Not keys(VK_NUMLOCK))
                SetKeyboardState keys(0)
          ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then   '=====WinNT
          'Simulate Key Press
            keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
          'Simulate Key Release
            keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY _
               Or KEYEVENTF_KEYUP, 0
          End If
        
End Sub

Function IsScrollLockOn()
        Dim o As OSVERSIONINFO
        
        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)
        IsScrollLockOn = keys(VK_SCROLL)
End Function

Sub ToggleScrollLock()
        Dim o As OSVERSIONINFO
        
        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)
        If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then  '=====Win95
            keys(VK_SCROLL) = Abs(Not keys(VK_SCROLL))
            SetKeyboardState keys(0)
        ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then   '=====WinNT
            'Simulate Key Press
            keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
            'Simulate Key Release
            keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
        End If
End Sub

Private Sub mySendKeys(sKeys As String, Optional bWait As Boolean = False)
    Dim bNumLockState As Boolean
    Dim bCapsLockState As Boolean
    Dim bScrollLockState As Boolean
    bNumLockState = IsNumLockOn()
    bCapsLockState = IsCapsLockOn()
    bScrollLockState = IsScrollLockOn()
    SendKeys sKeys, bWait
    If IsNumLockOn() <> bNumLockState Then
        ToggleNumLock
    End If
    If IsCapsLockOn() <> bCapsLockState Then
        ToggleCapsLock
    End If
    If IsScrollLockOn() <> bScrollLockState Then
        ToggleScrollLock
    End If
End Sub

Function fSendKeys(sKeys As String, Optional bWait As Boolean = False)
' Function to make it callable from macros
    mySendKeys sKeys, bWait
End Function
'******** Code End ***********
'----------------------------------------------------------------------------------------------