'Как видите, можно обрабатывать одновременное нажатие многих клавиш, чего не позволяет VB!!!

Private Sub tmrKey_Timer()
    diDEV.GetDeviceStateKeyboard diState 'Структура diState держит состояния всех клавиш

If diState.Key(200)<>0 then
     'Do Code Here
End If
If diState.Key(201)<>0 then
     'Do Code Here
End If
If diState.Key(202)<>0 then
     'Do Code Here
End If
    DoEvents  'Очень ОЧЕНЬ важно! Надо дать DirectX время обработать то, о чем вы его просили, иначе произойдет сбой .
End Sub

none (mnuContext) - NOTE: уберите флаг visible
---Speed 1 (mnuSpeed1)
---Speed 2 (mnuSpeed2)
---Speed 3 (mnuSpeed3)
--- - (sep2)
---Clear (mnuClear)
--- - (sep3)
--- Release Mouse (mnuSuspend)

'(DECARATIONS)
Option Explicit

Public objDX As New DirectX7
Public objDXEvent As DirectXEvent
Public objDI As DirectInput
Public objDIDev As DirectInputDevice

Public g_cursorx As Long
Public g_cursory As Long
Public g_Sensitivity
Public Const BufferSize = 10

Public EventHandle As Long
Public Drawing As Boolean
Public Suspended As Boolean

Public procOld As Long

' Windows API declares and constants

Public Const GWL_WNDPROC = (-4)
Public Const WM_ENTERMENULOOP = &H211
Public Const WM_EXITMENULOOP = &H212
Public Const WM_SYSCOMMAND = &H112

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Type POINTAPI
        x As Long
        y As Long
End Type
 

Sub Main()

  ' Показать сначала главную форму, чтобы мы могли использовать ее Handle.
  frmCanvas.Show
  .
  procOld = SetWindowLong(frmCanvas.hWnd, GWL_WNDPROC, AddressOf SysMenuProc)

  ' Инициализируем наш курсор
  g_cursorx = frmCanvas.ScaleWidth \ 2
  g_cursory = frmCanvas.ScaleHeight \ 2
  g_Sensitivity = 2
  frmCanvas.mnuSpeed2.Checked = True
 
  ' Создать DirectInput и установить мышь
  Set objDI = objDX.DirectInputCreate
  Set objDIDev = objDI.CreateDevice("guid_SysMouse")
  Call objDIDev.SetCommonDataFormat(DIFORMAT_MOUSE)
  Call objDIDev.SetCooperativeLevel(frmCanvas.hWnd, DISCL_FOREGROUND Or DISCL_EXCLUSIVE)
 
  ' Установить размер буфера
  Dim diProp As DIPROPLONG
  diProp.lHow = DIPH_DEVICE
  diProp.lObj = 0
  diProp.lData = BufferSize
  diProp.lSize = Len(diProp)
  Call objDIDev.SetProperty("DIPROP_BUFFERSIZE", diProp)

  ' Спросить об уведомлениях
 
  EventHandle = objDX.CreateEvent(frmCanvas)
  Call objDIDev.SetEventNotification(EventHandle)
 
  ' Включить мышь
  frmCanvas.AcquireMouse
 
End Sub
 

Public Function SysMenuProc(ByVal hWnd As Long, ByVal iMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long

' Эта процедура интерпретирует сообщения Windows и смотрит за теми, по которым
'надо выключить мышь

  If iMsg = WM_ENTERMENULOOP Then
    objDIDev.Unacquire
    frmCanvas.SetSystemCursor
  End If
 
  ' Вызов процедуры окна
  SysMenuProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)

End Function

'(DECLARATIONS)
Option Explicit
Implements DirectXEvent 'Вы заметите, что новый объект появится в первом списке окна кода

Sub AcquireMouse()
  Dim CursorPoint As POINTAPI
 
  ' Переместить наш курсор в позицию системного.
  Call GetCursorPos(CursorPoint)  ' Получить позицию перед тем, как Windows потеряет курсор
  Call ScreenToClient(hWnd, CursorPoint)
 
  On Error GoTo CANNOTACQUIRE
  objDIDev.Acquire
  g_cursorx = CursorPoint.x
  g_cursory = CursorPoint.y

  UpdateCursor
  frmCanvas.imgPencil.Visible = True
  On Error GoTo 0
  Exit Sub
CANNOTACQUIRE:
  Exit Sub
End Sub

Public Sub Popup()
  objDIDev.Unacquire
  SetSystemCursor
  Call PopupMenu(mnuContext) 'Всплывающее меню появится в координатах курсора
End Sub

Public Sub SetSystemCursor()
 'Поставить системный курсор в ту же позицию, что наш курсор и прекратить рисовать
  Dim point As POINTAPI
  imgPencil.Visible = False
  Drawing = False
  point.x = g_cursorx
  point.y = g_cursory
  Call ClientToScreen(hWnd, point)
  Call SetCursorPos(point.x, point.y)
End Sub

Public Sub UpdateCursor()
  ' Обновить позицию нашего курсора
  If g_cursorx < 0 Then g_cursorx = 0
  If g_cursorx >= frmCanvas.ScaleWidth Then g_cursorx = frmCanvas.ScaleWidth - 1
  If g_cursory < 0 Then g_cursory = 0
  If g_cursory >= frmCanvas.ScaleHeight Then g_cursory = frmCanvas.ScaleHeight - 1
  frmCanvas.imgPencil.Left = g_cursorx
  frmCanvas.imgPencil.Top = g_cursory
  If Drawing Then
    Line -(g_cursorx, g_cursory)
  End If
End Sub

Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)

' Здесь мы распознаем изменения в положении мыши. Обычно это движение по осям
' или нажатие или отпускание кнопки, но это может также означать "потерю" мыши.
' Note: нет события, означающего потерю мыши. Обычно потеря мыши означает,
' что окно приложения потеряло фокус

  Dim diDeviceData(1 To BufferSize) As DIDEVICEOBJECTDATA
  Dim NumItems As Integer
  Dim i As Integer
  Static OldSequence As Long
 
  ' Получить данные 
  On Error GoTo INPUTLOST
  NumItems = objDIDev.GetDeviceData(diDeviceData, 0)
  On Error GoTo 0
 
  ' Обработать данные
  For i = 1 To NumItems
    Select Case diDeviceData(i).lOfs
      Case DIMOFS_X
        g_cursorx = g_cursorx + diDeviceData(i).lData * g_Sensitivity
 
 
        If OldSequence <> diDeviceData(i).lSequence Then
          UpdateCursor
          OldSequence = diDeviceData(i).lSequence
        Else
          OldSequence = 0
        End If
 
      Case DIMOFS_Y
        g_cursory = g_cursory + diDeviceData(i).lData * g_Sensitivity
        If OldSequence <> diDeviceData(i).lSequence Then
          UpdateCursor
          OldSequence = diDeviceData(i).lSequence
        Else
          OldSequence = 0
        End If
 
      Case DIMOFS_BUTTON0
        If diDeviceData(i).lData And &H80 Then
          Drawing = True
 
          'Сохрянять запись для функции Line
          CurrentX = g_cursorx
          CurrentY = g_cursory
 
          'Рисовать точку в случае события Button-Up 
          PSet (g_cursorx, g_cursory)
        Else
          Drawing = False
        End If
 
      Case DIMOFS_BUTTON1
        If diDeviceData(i).lData = 0 Then  ' button up
          Popup
        End If
 
    End Select
  Next i
  Exit Sub
INPUTLOST:
' Windows украл у нас мышь.  Произошло DIERR_INPUTLOST , если пользователь переключился
' на другое приложение, но DIERR_NOTACQUIRED  произошло, если нажата кнопка Windows
  If (Err.Number = DIERR_INPUTLOST) Or (Err.Number = DIERR_NOTACQUIRED) Then
    SetSystemCursor
    Exit Sub
  End If 
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case 93         'Кнопка AppMenu
      Popup 'Покажем меню
    End Select
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim didevstate As DIMOUSESTATE
  'Мы хотим переопределения мыши, когда контекстное меню звкрыто, когда мы переключились
  'назад в приложение, или в других случаях, когда системный курсор более не нужен.
  'Если произошло событие MouseMove, мы знаем, что курсор находится в нашем приложении
  'и Windows генерирует мышиные сообщения, тогда настало время для переопределения.
  'Note: этот флаг меняется, когда окно получает мышь, даже если не было мышиной активности
  ' - например, если мы переключились в окно по Alt-Tab, или отменили контекстное меню
  'клавишей Esc.
   If Suspended Then Exit Sub    'Продолжить использование курсора Windows
  'Это событие вызывается снова, как только мы включили мышь. Чтобы предотвратить
  'установку курсора в центр окна, мы проверяем, а вдруг мышь уже включена, и если так, мы не
  'репозиционируем наш курсор. Единственный способ проверить, включена ли мышь -
  'получить данные 
  On Error GoTo NOTYETACQUIRED
  Call objDIDev.GetDeviceStateMouse(didevstate)
  On Error GoTo 0
  Exit Sub
NOTYETACQUIRED:
  Call AcquireMouse
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' Позволить отмену щелканьем на полотне
  If Button = 1 Then Suspended = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
  If procOld <> 0 Then
    Call SetWindowLong(hWnd, GWL_WNDPROC, procOld)
  End If
  If EventHandle <> 0 Then objDX.DestroyEvent EventHandle
End Sub

Private Sub mnuClear_Click()
   Cls
End Sub

Private Sub mnuSpeed1_Click()
  g_Sensitivity = 1
  mnuSpeed1.Checked = True
  mnuSpeed2.Checked = False
  mnuSpeed3.Checked = False
End Sub

Private Sub mnuSpeed2_Click()
  g_Sensitivity = 2
  mnuSpeed2.Checked = True
  mnuSpeed1.Checked = False
  mnuSpeed3.Checked = False
End Sub

Private Sub mnuSpeed3_Click()
  g_Sensitivity = 3
  mnuSpeed3.Checked = True
  mnuSpeed1.Checked = False
  mnuSpeed2.Checked = False
End Sub

Private Sub mnuSuspend_Click()
  Suspended = Not Suspended
  imgPencil.Visible = Not Suspended
End Sub

'(DECLARATIONS)
Option Explicit
Implements DirectXEvent    'Здесь проверяется информация джойстика

Dim dx As New DirectX7   'Главный объект DirectX 
Dim di As DirectInput     ' Объект DirectInput, позже будет создан из объекта DirectX
Dim diDev As DirectInputDevice  'Представляет джойстик
Dim diDevEnum As DirectInputEnumDevices  'Перечисляет доступные устройства
Dim EventHandle As Long   'Содержит события
Dim joyCaps As DIDEVCAPS  'Держит информацию о джойстике
Dim js As DIJOYSTATE 
Dim DiProp_Dead As DIPROPLONG
Dim DiProp_Range As DIPROPRANGE
Dim DiProp_Saturation As DIPROPLONG
Dim AxisPresent(1 To 8) As Boolean
Dim running As Boolean    'Программа еще живая?

Sub CLRLISTS()    'Маленькая процедура для очистки всего, чего можно
    lstJoyAxis.Clear
    lstButton.Clear
End Sub

Sub IdentifyAxes(diDev As DirectInputDevice)
'Эта процедура узнает, сколько присутствует осей, например: 
    'Верх - Низ
    'Лево - Право
    'Диагонали
   ' Недостаточно перечислить оси, нам надо знать какие части присутствуют    .
   Dim didoEnum As DirectInputEnumDeviceObjects
   Dim dido As DirectInputDeviceObjectInstance
   Dim i As Integer
   For i = 1 To 8
     AxisPresent(i) = False
   Next
   ' Перечислить оси
   Set didoEnum = diDev.GetDeviceObjectsEnum(DIDFT_AXIS)
   'Проверить данные для каждой оси, чтобы узнать каждую из них
   For i = 1 To didoEnum.GetCount
     Set dido = didoEnum.GetItem(i)
         Select Case dido.GetOfs
            Case DIJOFS_X
              AxisPresent(1) = True
            Case DIJOFS_Y
              AxisPresent(2) = True
            Case DIJOFS_Z
              AxisPresent(3) = True
            Case DIJOFS_RX
              AxisPresent(4) = True
            Case DIJOFS_RY
              AxisPresent(5) = True
            Case DIJOFS_RZ
              AxisPresent(6) = True
            Case DIJOFS_SLIDER0
              AxisPresent(7) = True
            Case DIJOFS_SLIDER1
              AxisPresent(8) = True
         End Select
   Next
End Sub

Sub InitDirectInput()

    Set di = dx.DirectInputCreate()  'Создать DI из DX. Это надо сделать перед всем остальным
    Set diDevEnum = di.GetDIEnumDevices(DIDEVTYPE_JOYSTICK, DIEDFL_ATTACHEDONLY)  'Какие типы джойстиков распознавать
    If diDevEnum.GetCount = 0 Then  'Если нет джойстиков, уведомить пользователя
      MsgBox "No joystick attached."
      Unload Me
    End If

    'Добавить подключенные джойстики в список
    Dim i As Integer
    For i = 1 To diDevEnum.GetCount
        Call lstJoySticks.AddItem(diDevEnum.GetItem(i).GetInstanceName) 'Здесь перечисляются все устройства 
    Next

    'Получить handle события, чтобы ассоциировать его с устройстом 
    EventHandle = dx.CreateEvent(Me)  'Создать событие для DirectX.
    'Событие происходит когда что-нибудь случается, например пользователь нажмет
    'кнопку. Мы используем это чтобы решить что делать, когда получаем соответсвующее
    'событие - идти быстрее/стрелять/идти влево...

    Exit Sub

Error_Out:
    MsgBox "Error initializing DirectInput."  'Происходит, когда у пользователя нет DX7, или что-то у него криво с системой
    Unload Me
End Sub

Sub SetProp()
    ' Установить пределы для всех осей
    'По X - от 0 до 10000 (лево-право)
    'По Y - от 0 до 10000 (верх-низ)

    With DiProp_Range
        .lHow = DIPH_DEVICE
        .lSize = Len(DiProp_Range)
        .lMin = 0
        .lMax = 10000
    End With
    diDev.SetProperty "DIPROP_RANGE", DiProp_Range
End Sub

Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)
' Вызывается, когда меняется состояние джойстика
'Мы проверяем новое состояние и обновляем отображение
'Сначала получаем позиции, затем - состояния кнопок
    Dim i As Integer
    Dim ListPos As Integer
    Dim S As String 
    If diDev Is Nothing Then Exit Sub 'Если небыло инициализации, выходим

    'Получить инфо об устройстве
    On Local Error Resume Next
    diDev.GetDeviceStateJoystick js
    If Err.Number = DIERR_NOTACQUIRED Or Err.Number = DIERR_INPUTLOST Then
        diDev.Acquire 'При включении, DirectX передает всю информацию переменным внутри VB.
        Exit Sub
    End If 
    On Error GoTo err_out

    'Отобразить осевые координаты
    ListPos = 0
    For i = 1 To 8
        If AxisPresent(i) Then
           Select Case i
               Case 1
                   S = "X: " & js.x  'Вызов js.x вернет координату.
               Case 2
                   S = "Y: " & js.y
               Case 3
                   S = "Z: " & js.z
               Case 4
                   S = "RX: " & js.rx
               Case 5
                   S = "RY: " & js.ry
               Case 6
                   S = "RZ: " & js.rz
               Case 7
                   S = "Slider0: " & js.slider(0)
               Case 8
                   S = "Slider1: " & js.slider(1) 
           End Select
           lstJoyAxis.List(ListPos) = S 'Добавить переменную в список - теперь юзер все увидит            ListPos = ListPos + 1

        End If
     Next 
    ' Кнопки
    For i = 0 To joyCaps.lButtons - 1
        Select Case js.buttons(i)
        Case 0
            lstButton.List(i) = "Button " + CStr(i + 1) + ": Up" 'Говорим юзеру о состоянии кнопок

        Case Else
            lstButton.List(i) = "Button " + CStr(i + 1) + ": Down" 
        End Select
    Next 
    Me.Caption = "Joystick Sample: Available"
    Exit Sub 
err_out:
    MsgBox Err.Description & " : " & Err.Number, vbApplicationModal 'Возвращаем сообщение об ошибке
    End
End Sub

Private Sub Form_Load()  
    running = True 'Внутренняя переменная
    InitDirectInput 'С этого все начинается.
End Sub

Private Sub Form_Unload(cancel As Integer)
        If EventHandle <> 0 Then dx.DestroyEvent EventHandle 'Вы должны все уничтожить.
        running = False
        DoEvents
        End
End Sub

Private Sub lstJoySticks_Click() 'Происходит, когда пользователь выбирает новый джойстик из списка 
    On Local Error Resume Next
    Call CLRLISTS  'Очистить список перед тем, как добавим в него новые значения
    'Создать "joystick device"
    Set diDev = Nothing 'Очистить старые данные перед помещением новых
    Set diDev = di.CreateDevice(diDevEnum.GetItem(lstJoySticks.ListIndex + 1).GetGuidInstance)
    diDev.SetCommonDataFormat DIFORMAT_JOYSTICK
    diDev.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    'THE COOPERATIVELEVEL: указывает, как ваша программа использует ресурсы, делясь ими
    'с другими приложениями или использует только сама.
    ' Если делится, то ищем какой объект устройства их имеет
    diDev.GetCapabilities joyCaps
    Call IdentifyAxes(diDev)

    'Спросим об событии
    Call diDev.SetEventNotification(EventHandle)

    'Установить "мертвую зону" для осей X и Y в 10% от возвожного перемещения
    With DiProp_Dead
        .lData = 1000
        .lObj = DIJOFS_X
        .lSize = Len(DiProp_Dead)
        .lHow = DIPH_BYOFFSET
        .lObj = DIJOFS_X
        diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
        .lObj = DIJOFS_Y
        diDev.SetProperty "DIPROP_DEADZONE", DiProp_Dead
    End With

    'Установить "светлую зону" в 5%
    With DiProp_Saturation
        .lData = 9500
        .lHow = DIPH_BYOFFSET
        .lSize = Len(DiProp_Saturation)
        .lObj = DIJOFS_X
         diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
        .lObj = DIJOFS_Y
         diDev.SetProperty "DIPROP_SATURATION", DiProp_Saturation
    End With

    SetProp
 

    diDev.Acquire
    Me.Caption = "Joystick Sample: Querying Properties"

    'Получить список текущих свойств
    ' USB joysticks не вернет ничего, пока мы не двинем его
    ' поэтому сделаем первый раз это за него
    DirectXEvent_DXCallback 0

    ' Обрабатываем устройство так, чтобы получить события, когда они будут
    ' Обычно делается в главном рисующем цикле игрушек

    While running = True
        DoEvents
        diDev.Poll
    Wend
End Sub