CODEWITHSUNDEEP
vbaexcel
Faux
Faux

Reputation: 103

Excel VBA onkey macro to work while another macro is running

I have a macro that lets you move marked cell around with arrow keys. This is the code to move it down 

Sub MoveMarkedDown()

    Dim noDo As Boolean
    With myMarkedCell
        Select Case .Row
            Case Is >= 36
                noDo = True
            Case 35
                With .Offset(1, 0)
                    If (.Interior.ColorIndex = 3) Or IsBlockCell(.Cells) Then
                        noDo = True
                    End If
                End With
            Case Else
                With .Offset(1, 0)
                    If IsBlockCell(.Cells) Or ((.Interior.ColorIndex = 3) And IsBlockCell(.Offset(1, 0).Cells)) Then
                        noDo = True
                    End If
                End With
        End Select
    End With
    If noDo Then
        Beep
    Else
        MoveMarkedCell 1, 0
    End If
End Sub

I have binded they arrow key with application.onkey

Sub test()

    Application.OnKey "{LEFT}", "MoveMarkedLeft"
    Application.OnKey "{DOWN}", "MoveMarkedDown"
    Application.OnKey "{RIGHT}", "MoveMarkedRight"
    Application.OnKey "{UP}", "MoveMarkedUp"
End Sub

And another macro that paints a cell in green and moves it back and forth:

Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecons As Long)

Private Sub Button1_Click()
Move ''start macro button
End Sub

Sub Move()
gr = 1
st = 1
While Cells(2, 2) = 0
If st > 1 Then
  Cells(5, st - 1).Clear
  End If
Cells(5, st + 1).Clear
Cells(5, st).Interior.Color = vbGreen
st = st + gr
If st > 48 Then
gr = -1
End If
If st < 2 Then
gr = 1
End If
Sleep 100
 DoEvents
 Wend
End Sub

And when i launch the code that moves the cell back and forth the macro that lets you move marked cell stops working. What i did wrong? Is it possible to do them both work?

MyMarkedCell is defined like this:

Sub MoveMarkedCell(VMove As Long, HMove As Long)
    With ActiveSheet.MarkedCell
        .Value = vbNullString
        Set ActiveSheet.MarkedCell = .Offset(VMove, HMove)
    End With
    With ActiveSheet.MarkedCell
        .Value = "X"
        If .Interior.ColorIndex = 3 Then
            .Interior.ColorIndex = xlNone
            If (.Column + HMove) * (.Row + VMove) <> 0 Then .Offset(VMove, HMove).Interior.ColorIndex = 3
        End If
        Application.Goto .Cells, False
    End With
End Sub

Function myMarkedCell() As Range
    If ActiveSheet.MarkedCell Is Nothing Then
        ActiveSheet.Worksheet_Activate
    End If
    Set myMarkedCell = ActiveSheet.MarkedCell
End Function

Upvotes: 4

Views: 1408

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149295

You can't use Application.OnKey like that because in VBA only one procedure can be run at a time. The alternative is to use the GetAsyncKeyState API

Here is an example. When you run the below code, the green cells will start moving. And when you press the Arrow key, it will prompt you the name of the key you pressed. Simply replace the message boxes with the relevant procedures. 

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Const VK_LEFT As Long = 37
Const VK_DOWN As Long = 40
Const VK_RIGHT As Long = 39
Const VK_UP As Long = 38

Sub Move()
    gr = 1: st = 1
    While Cells(2, 2) = 0
        '~~> Do the checks here and direct them to the relevant sub
        If GetAsyncKeyState(VK_LEFT) <> 0 Then
            MsgBox "Left Arrow Pressed"
            'MoveMarkedLeft
            Exit Sub
        ElseIf GetAsyncKeyState(VK_RIGHT) <> 0 Then
            MsgBox "Right Arrow Pressed"
            Exit Sub
        ElseIf GetAsyncKeyState(VK_UP) <> 0 Then
            MsgBox "Up Arrow Pressed"
            Exit Sub
        ElseIf GetAsyncKeyState(VK_DOWN) <> 0 Then
            MsgBox "Down Arrow Pressed"
            Exit Sub
        End If

        If st > 1 Then Cells(5, st - 1).Clear
        Cells(5, st + 1).Clear
        Cells(5, st).Interior.Color = vbGreen
        st = st + gr
        If st > 48 Then gr = -1
        If st < 2 Then gr = 1
        Sleep 100
        DoEvents
    Wend
End Sub

Upvotes: 5

Related Questions