VB6 Sendkeys in Windows Vista

The Sendkeys function of VB6 doesn't work under Windows Vista. Here's a quick and dirty page showing how I got Sendkeys working under Vista by making a function intercept the call to VBA.SendKeys and use Windows api functions instead. I haven't tried this under Windows 7 yet, though I'd expect that to behave the same as Vista with regards to Sendkeys.

Add a module to your project and call it something like Vista_SendKeys.bas. Paste the following load of code into it. Enable of diasable the interception by setting USE_MY_SENDKEYS to true or false as required for debugging.

Option Explicit

' -----------------------------------------------------
' - Module for intercepting calls to VBA.Sendkeys and -
' - using Windows API calls instead to send the keyup -
' - and keydow events                                 -
' -----------------------------------------------------

Private Const USE_MY_SENDKEYS As Boolean = True

Private Declare Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, ByVal bScan As Byte, _
    ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
   
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2

Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA" ( _
    ByVal cChar As Byte) As Integer
Private Declare Function VkKeyScanW Lib "user32" ( _
    ByVal cChar As Integer) As Integer
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Sub KeyDown(ByVal vKey As KeyCodeConstants)
    Call keybd_event(vKey, 0, KEYEVENTF_EXTENDEDKEY, 0)
End Sub

Public Sub KeyUp(ByVal vKey As KeyCodeConstants)
    Call keybd_event(vKey, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
End Sub

Public Function keyCode(ByVal sChar As String) As KeyCodeConstants
    
    Dim bNt As Boolean
    Dim iKeyCode As Integer
    Dim b() As Byte
    Dim iKey As Integer
    Dim vKey As KeyCodeConstants
    Dim iShift As ShiftConstants
    
    ' Determine if we have Unicode support or not:
    bNt = ((GetVersion() And &H80000000) = 0)
    
    ' Get the keyboard scan code for the character:
    If (bNt) Then
        b = sChar
        CopyMemory iKey, b(0), 2
        iKeyCode = VkKeyScanW(iKey)
    Else
        b = StrConv(sChar, vbFromUnicode)
        iKeyCode = VkKeyScan(b(0))
    End If
    
    keyCode = (iKeyCode And &HFF&)
    
End Function

Public Function Sendkeys(ByVal sString As String, _
    Optional ByVal fWait As Boolean = False)

    ' Intercepts the standard SendKeys
    
    Dim key As KeyCodeConstants
    
    If Not USE_MY_SENDKEYS Then
        VBA.Sendkeys sString, fWait
    Else
        Select Case UCase$(sString)
        Case UCase$(SENDKEYS_TAG_BS)
            key = keyCode(Chr(8))
        Case UCase$(SENDKEYS_TAG_DELETE)
            key = keyCode(Chr(127))
        Case UCase$(SENDKEYS_TAG_LEFT)
            key = KeyCodeConstants.vbKeyLeft
        Case UCase$(SENDKEYS_TAG_RIGHT)
            key = KeyCodeConstants.vbKeyRight
        Case UCase$(SENDKEYS_TAG_RETURN)
            key = keyCode(Chr(13))
        Case Else
            key = keyCode(sString)
        End Select
    
        Call KeyDown(key)
        Call KeyUp(key)
        
    End If

End Function