Option Explicit

Dim dx As New DirectX7
Dim di As DirectInput
Dim diDEV As DirectInputDevice
Dim diState As DIKEYBOARDSTATE
Dim iKeyCounter As Integer

Implements DirectXEvent

Dim DXEvent As Long

Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)
  If diDEV Is Nothing Then Exit Sub

  On Local Error Resume Next
  diDEV.GetDeviceStateKeyboard diState

  If Err.Number = DIERR_NOTACQUIRED Then
    diDEV.Acquire
  End If

  For iKeyCounter = 0 To 255
    If diState.Key(iKeyCounter) <> 0 Then
      lstKeys.AddItem "Taste " & iKeyCounter & _
          " wurde gedrückt", 0
    End If
  Next

  ' Hier zur Demonstration nur ein Teil des
  ' Tastaturabfragecodes
  If diState.Key(DIK_A) <> 0 Then
    Button(10).Value = True
  Else
    Button(10).Value = False
  End If

  If diState.Key(DIK_B) <> 0 Then
    Button(23).Value = True
  Else
    Button(23).Value = False
  End If

  If diState.Key(DIK_SEMICOLON) <> 0 Then
    Button(27).Value = True
  Else
    Button(27).Value = False
  End If

  If diState.Key(DIK_COMMA) <> 0 Then
    Button(28).Value = True
  Else
    Button(28).Value = False
  End If

  If diState.Key(DIK_PERIOD) <> 0 Then
    Button(29).Value = True
  Else
    Button(29).Value = False
  End If

  If diState.Key(DIK_B) And diState.Key(DIK_LMENU) <> 0 Then
    Unload Me
    Exit Sub
  End If

  DoEvents
  lstKeys.Selected(0) = True
End Sub

Private Sub Form_Load()
  Set di = dx.DirectInputCreate()

  If Err.Number <> 0 Then
     MsgBox "Fehler beim Starten von DirectInput." & vbCrLf & _
        "Bitte installieren Síe DirectX" & _
        " um dieses Beispiel zu testen.", vbApplicationModal
     End
  End If

  Set diDEV = di.CreateDevice("GUID_SysKeyboard")

  diDEV.SetCommonDataFormat DIFORMAT_KEYBOARD
  diDEV.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or _
      DISCL_NONEXCLUSIVE

  Me.Show

  DXEvent = dx.CreateEvent(Me)
  diDEV.SetEventNotification DXEvent

  diDEV.Acquire
End Sub

Private Sub Form_Unload(Cancel As Integer)
  If DXEvent <> 0 Then dx.DestroyEvent (DXEvent)
  diDEV.Unacquire
End Sub

Private Sub tmrKey_Timer()
  dx.SetEvent DXEvent
End Sub