IF keystroke pressed (eg "A") THEN... whilst a macro is running

[exceluser999]

I need quick help. Not sure if it's possible but I'm hoping it is.

I have a loop in my code that increases the integer r by 1 with every loop. I want an IF statement within the loop in that if I press a key (eg "A"), r will increase by 1; so in that particular loop r will have increased by 2. See code example below:

Do Until r = 29


Cells(r, c).Interior.ColorIndex = 1
Cells(r, c + 1).Interior.ColorIndex = 1
Cells(r, c + 2).Interior.ColorIndex = 1
Cells(r + 1, c).Interior.ColorIndex = 1
Cells(r + 2, c).Interior.ColorIndex = 1
Cells(r + 2, c + 1).Interior.ColorIndex = 1
Cells(r + 2, c + 2).Interior.ColorIndex = 1
Cells(r + 3, c + 2).Interior.ColorIndex = 1
Cells(r + 4, c + 2).Interior.ColorIndex = 1
Cells(r + 4, c + 1).Interior.ColorIndex = 1
Cells(r + 4, c).Interior.ColorIndex = 1


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
This is where i want the IF statement so if at any point during the loop, the key "A" has been recognised to have been pressed then r = r + 1 here.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



' Allowing time for it to hold position
Application.Wait Now + TimeValue("00:00:01")

' increasing r by one
r = r + 1


Loop

 

[Jaafar Tribak]

Something like this maybe : the code below will populate cells A1 to A10 with 1 to 10 every second and if the key 'A' is pressed it will jump by 1.

Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Sub Test()

    Dim r As Long
    Dim t As Single
    
    For r = 1 To 10
        If GetAsyncKeyState(vbKeyA) Then r = r + 1
        Cells(r, 1) = r
        t = Timer
        Do: Loop Until Timer - t >= 1
    Next r

End Sub

 

[Jaafar Tribak]

The above code has an issue in that it doesn't absorbe the keystrokes and so the key 'A' ends up sent to the excel window after the macro is finished.

Here is an alternative code that addresses the above mentioned problem :

Option Explicit

Type POINTAPI
        x As Long
        y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        temps As Long
        pt As POINTAPI
    End Type
    
    Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
        (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, _
        ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    
    Declare PtrSafe Function WaitMessage Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        temps As Long
        pt As POINTAPI
    End Type
    
    Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
        (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
        ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    
    Declare Function WaitMessage Lib "user32" () As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Const WM_KEYDOWN = &H100
Const PM_REMOVE = &H1

Sub Test()

    Dim r As Long
    Dim t As Single
    Dim tMsg As MSG

    For r = 1 To 10
        WaitMessage
        If PeekMessage(tMsg, Application.hwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            If Chr(CLng(tMsg.wParam)) = "A" Then r = r + 1
        End If
        Cells(r, 1) = r
        t = Timer: Do: Loop Until Timer - t >= 1
    Next r

End Sub

 

[Jaafar Tribak]

Again, ignore the previous code as it doesn't distinguish between Uppaercase 'A' and Lowercase 'a' .

Use the following code instead :

Option Explicit

Type POINTAPI
    x As Long
    y As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        temps As Long
        pt As POINTAPI
    End Type
    
    Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
        (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, _
        ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    
    Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        temps As Long
        pt As POINTAPI
    End Type
    
    Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _
        (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
        ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    
    Declare Function WaitMessage Lib "user32" () As Long
    Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Const WM_KEYDOWN = &H100
Const WM_CHAR = &H102
Const PM_REMOVE = &H1


Sub Test()

    Dim r As Long
    Dim t As Single
    Dim tMsg As MSG

    For r = 1 To 10
        WaitMessage
        If PeekMessage(tMsg, Application.hwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
            TranslateMessage tMsg
            If PeekMessage(tMsg, Application.hwnd, WM_CHAR, WM_CHAR, PM_REMOVE) Then
                If tMsg.wParam = 65 Then r = r + 1
            End If
        End If
        Cells(r, 1) = r
        t = Timer: Do: Loop Until Timer - t >= 1
    Next r

End Sub

 

[exceluser999]

Thank you for your quick response, it’s much appreciated.

I am not at my PC right now but will check it out when I go back on it and update you on my results.

Thanks again!

 

[exceluser999]

Just tested it out. The second two pieces of code don't seem to do anything when I press "A", however the first piece of code works almost perfectly - like you said the only problem is the selected cell populates with loads of "a's" once the macro is finished. Is there any simple add on to the first piece to stop this from happening?

What you have given me so far has been such a help though! Thanks.

 

[Jaafar Tribak]

Just tested it out. The second two pieces of code don't seem to do anything when I press "A",

Strange! they should work .

.. however the first piece of code works almost perfectly - like you said the only problem is the selected cell populates with loads of "a's" once the macro is finished. Is there any simple add on to the first piece to stop this from happening?

Try this variation of the first code and see if it works for you .. if this doesn't work for you either then the only remaining solution I think of is to install a keyboard hook which is taking this too far.

Anyway here is the updated code :

Option Explicit

Private Type KeyboardBytes
     kbByte(0 To 255) As Byte
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Declare PtrSafe Function SetKeyboardState Lib "user32" (lppbKeyState As KeyboardBytes) As Long
    Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As KeyboardBytes) As Long
    Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Declare Function SetKeyboardState Lib "user32" (lppbKeyState As KeyboardBytes) As Long
    Declare Function GetKeyboardState Lib "user32" (pbKeyState As KeyboardBytes) As Long
    Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        

Sub Test()

    Dim r As Long, i As Long, t As Single
    Dim tCurKB As KeyboardBytes, tInitKB As KeyboardBytes
    
    Application.EnableCancelKey = xlErrorHandler
    On Error GoTo errHandler
    
    GetKeyboardState tInitKB
    For r = 1 To 10
        For i = 0 To 255
            tCurKB.kbByte(i) = 255
            SetKeyboardState tCurKB
        Next
        If GetAsyncKeyState(vbKeyA) Then r = r + 1
        Cells(r, 1) = r
        t = Timer: Do: Loop Until Timer - t >= 1
    Next r
    
errHandler:
    
    DoEvents
    SetActiveWindow Application.hwnd
    SetKeyboardState tInitKB

End Sub