Tipp 0042 DirectInput - Maus
Autor/Einsender:
Datum:
  Jack Hoxley
27.04.2001
Entwicklungsumgebung:
DirectX-Version:
  VB 6
DirectX 7
Dieses Beispiel zeigt alle Möglichkeiten der Maussteuerung mittels DirectInput. So kann u.a. die Cursorgeschwindigkeit vorgegeben, die einzelnen Maus-Tasten abgefragt und der Mausbereich eingeschränkt und wieder aufgehoben werden. Auch die Positionsabfrage wird anschaulich dargestellt.
 Der Autor hat den Quellcode im Download-Beispiel vorbildlich kommentiert.
Code im Codebereich des Moduls
 
Option Explicit
Implements DirectXEvent

Dim DX As New DirectX7
Dim DI As DirectInput
Dim DIDev As DirectInputDevice
Dim CursorX As Long
Dim CursorY As Long

Const BufferSize = 10

Dim Button_0 As Boolean
Dim Button_1 As Boolean
Dim Button_2 As Boolean
Dim Button_3 As Boolean

Dim EventHandle As Long
Dim NotActive As Boolean

Private Declare Function GetCursorPos Lib "user32" (lpPoint _
    As POINTAPI) As Long

Private Declare Function SetCursorPos Lib "user32" (ByVal X _
    As Long, ByVal Y As Long) As Long

Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd _
    As Long, lpPoint As POINTAPI) As Long

Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd _
    As Long, lpPoint As POINTAPI) As Long

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Sub AquireMouse()
  Dim CursorCoord As POINTAPI

  Call GetCursorPos(CursorCoord)
  Call ScreenToClient(hWnd, CursorCoord)

  On Error GoTo AQUIREERROR

  DIDev.Acquire

  CursorX = CursorCoord.X
  CursorY = CursorCoord.Y

  UpdateCursor
  imgCursor.Visible = True
  On Error GoTo 0
  Exit Sub

AQUIREERROR:
  Exit Sub
End Sub

Sub CleanUp()
  Dim m_point As POINTAPI

  imgCursor.Visible = False
  DIDev.Unacquire

  m_point.X = CursorX
  m_point.Y = CursorY

  Call ClientToScreen(hWnd, m_point)
  Call SetCursorPos(m_point.X, m_point.Y)
End Sub

Sub Initialise()
  CursorX = Me.ScaleWidth \ 2
  CursorY = Me.ScaleHeight \ 2
  Call UpdateToolBox

  Set DI = DX.DirectInputCreate
  Set DIDev = DI.CreateDevice("GUID_SYSMOUSE")
  Call DIDev.SetCommonDataFormat(DIFORMAT_MOUSE)
  Call DIDev.SetCooperativeLevel(Me.hWnd, DISCL_FOREGROUND Or _
       DISCL_EXCLUSIVE)

  Dim Property As DIPROPLONG
  Property.lHow = DIPH_DEVICE
  Property.lObj = 0
  Property.lData = BufferSize
  Property.lSize = Len(Property)
  Call DIDev.SetProperty("DIPROP_BUFFERSIZE", Property)

  EventHandle = DX.CreateEvent(Me)
  Call DIDev.SetEventNotification(EventHandle)

  AquireMouse
End Sub

Sub UpdateCursor()
  If CursorX < 0 Then CursorX = 0
  If CursorX >= Me.ScaleWidth Then CursorX = Me.ScaleWidth - 1

  If CursorY < 0 Then CursorY = 0
  If CursorY >= Me.ScaleHeight Then CursorY = Me.ScaleHeight - 1

  imgCursor.Left = CursorX
  imgCursor.Top = CursorY
End Sub

Sub UpdateToolBox()
  Form2.lblX.Caption = "CurrentX: " & CStr(CursorX)
  Form2.lblY.Caption = "CurrentY: " & CStr(CursorY)
  Form2.lblButton0.Caption = "Button 0: " & CStr(Button_0)
  Form2.lblButton1.Caption = "Button 1: " & CStr(Button_1)
  Form2.lblButton2.Caption = "Button 2: " & CStr(Button_2)
  Form2.lblButton3.Caption = "Button 3: " & CStr(Button_3)
End Sub

Private Sub DirectXEvent_DXCallback(ByVal eventid As Long)

  Dim DIDeviceData(1 To BufferSize) As DIDEVICEOBJECTDATA
  Dim NumItems As Integer
  Dim i As Integer
  Static OldSequence As Long

  On Error GoTo INPUTLOST
  NumItems = DIDev.GetDeviceData(DIDeviceData, 0)
  On Error GoTo 0

  For i = 1 To NumItems
    Select Case DIDeviceData(i).lOfs
      Case DIMOFS_X
        CursorX = CursorX + DIDeviceData(i).lData * _
                Form2.scrlSpeed.Value
        If OldSequence <> DIDeviceData(i).lSequence Then
          UpdateCursor
          OldSequence = DIDeviceData(i).lSequence
        Else
          OldSequence = 0
        End If

      Case DIMOFS_Y
        CursorY = CursorY + DIDeviceData(i).lData * _
                Form2.scrlSpeed.Value
        If OldSequence <> DIDeviceData(i).lSequence Then
          UpdateCursor
          OldSequence = DIDeviceData(i).lSequence
        Else
          OldSequence = 0
        End If

      Case DIMOFS_BUTTON0
        Button_0 = True
        If DIDeviceData(i).lData = 0 Then
          Button_0 = False
        End If

      Case DIMOFS_BUTTON1
        Button_1 = True
        If DIDeviceData(i).lData = 0 Then
          Button_1 = False
        End If

      Case DIMOFS_BUTTON2
        Button_2 = True
        If DIDeviceData(i).lData = 0 Then
          Button_2 = False
        End If

      Case DIMOFS_BUTTON3
        Button_3 = True
        If DIDeviceData(i).lData = 0 Then
          Button_3 = False
        End If
    End Select
  Next i

  UpdateToolBox
  Exit Sub

INPUTLOST:
  If (Err.Number = DIERR_INPUTLOST) Or (Err.Number = _
         DIERR_NOTACQUIRED) Then
     CleanUp
     Exit Sub
  End If
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case vbKeyEscape
      NotActive = True
      DIDev.Unacquire
      CleanUp
      Exit Sub
    Case vbKeyReturn
      NotActive = False
  End Select
End Sub

Private Sub Form_Load()
  Form2.Show
  DoEvents
  Initialise
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  If NotActive = True Then Exit Sub
  Dim didevstate As DIMOUSESTATE

  On Error GoTo NOTYETACQUIRED
  Call DIDev.GetDeviceStateMouse(didevstate)
  On Error GoTo 0
  Exit Sub

NOTYETACQUIRED:
  Call AquireMouse
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Unload Form2
  If EventHandle <> 0 Then DX.DestroyEvent EventHandle
End Sub
 
Code im Codebereich von Form2
 
Private Sub scrlSpeed_Change()
  Sensitivity = scrlSpeed.Value
End Sub
 
Weitere Links zum Thema
DirectInput - Tastatur
DirectInput - GamePad & Joystick
Hinweis
Um dieses Beispiel ausführen zu können, wird die DirectX 7 for Visual Basic Type Library benötigt (siehe dazu die Erläuterungen in der DirectX-Rubrik).

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (6,4 kB) Downloads bisher: [ 2522 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 29. August 2011