JOYSTICK , MANETTE GESTION EXEMPLE

Option Explicit
Private Declare Function joyGetDevCaps Lib "winmm.dll" Alias "joyGetDevCapsA" (ByVal id As Long, lpCaps As JOYCAPS, ByVal uSize As Long) As Long
Private Declare Function joyGetPos Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFO) As Long

Const MAXPNAMELEN = 32

Private Type JOYCAPS
        wMid As Integer
        wPid As Integer
        szPname As String * MAXPNAMELEN
        wXmin As Long
        wXmax As Long
        wYmin As Long
        wYmax As Long
        wZmin As Long
        wZmax As Long
        wNumButtons As Long
        wPeriodMin As Long
        wPeriodMax As Long
End Type

Private Type JOYINFO
        wXpos As Long
        wYpos As Long
        wZpos As Long
        wButtons As Long
End Type

'Constante d'erreur de l'api
Const JOYERR_NOERROR = 0
Const JOYERR_BASE As Long = 160
Const JOYERR_UNPLUGGED As Long = (JOYERR_BASE + 7)
Const MMSYSERR_BASE As Long = 0
Const MMSYSERR_NODRIVER As Long = (MMSYSERR_BASE + 6)
Const MMSYSERR_INVALPARAM As Long = (MMSYSERR_BASE + 11)
Const JOYSTICK1 As Long = &H0
Const JOYSTICK2 As Long = &H1


 Const JOY_BUTTON1 = &H1
 Const JOY_BUTTON10 = &H200&
 Const JOY_BUTTON2 = &H2
 Const JOY_BUTTON2CHG = &H200
 Const JOY_BUTTON3 = &H4
 Const JOY_BUTTON3CHG = &H400
 Const JOY_BUTTON4 = &H8
 Const JOY_BUTTON4CHG = &H800
 Const JOY_BUTTON5 = &H10&
 Const JOY_BUTTON6 = &H20&
 Const JOY_BUTTON7 = &H40&
 Const JOY_BUTTON8 = &H80&
 Const JOY_BUTTON9 = &H100&


'Flag de fin de la boucle de jeux
Dim loopEnd As Boolean

'Variable pr conserver les bornes
Dim MaxX As Long
Dim MaxY As Long

Dim MinX As Long
Dim MinY As Long

'Position relative Joystick => fenetre
Dim RelativeX As Long
Dim RelativeY As Long


Dim lgCurseur As Long
Dim htCurseur As Long

Dim HalflgCurseur As Long
Dim HalfhtCurseur As Long

Dim nbButton As Long




Private Sub Form_Load()
Dim rt As Long
Dim JoyTestInfo As JOYINFO
Dim JoyStickCaps As JOYCAPS

'Connexion Ok ?
rt = joyGetPos(JOYSTICK1, JoyTestInfo)

'gestion des ERR
If rt <> JOYERR_NOERROR Then
    If rt = JOYERR_UNPLUGGED Then
        MsgBox "Joystick non présent" & vbCrLf & "Fin de l'application..."
    ElseIf rt = MMSYSERR_NODRIVER Then
        MsgBox "Pilote non installé" & vbCrLf & "Fin de l'application..."
    Else
        MsgBox "Erreur Inconnue" & vbCrLf & "Fin de l'application..."
    End If
        
    Unload Me
    Exit Sub
End If

'Recupere les position Minimum et Maximum du peripherique
joyGetDevCaps JOYSTICK1, JoyStickCaps, Len(JoyStickCaps)

'Attrib des bornes
With JoyStickCaps
    MaxX = .wXmax
    MinX = .wXmin
    MaxY = .wYmax
    MinY = .wYmin
End With

nbButton = JoyStickCaps.wNumButtons 'nb  bouttons
frmBB.Caption = nbButton & " bouttons sur le Joystick "
lblInfo.Caption = JoyStickCaps.szPname 'nom de drv

Dim nextL As Integer
Dim nextH As Integer

nextL = pctB(0).Left + pctB(0).Width + 10 'decalage boutons
nextH = pctB(0).Top
Dim i As Integer

'Création des bouttons
For i = 1 To nbButton - 1
    Load pctB(i)
    pctB(i).Left = nextL
    pctB(i).Top = nextH
    nextL = pctB(i).Left + pctB(i).Width + 10
    pctB(i).Visible = True
Next i

RunLoop


End Sub

Private Sub Form_Resize()

'Valeurs relative en fonction de la taille de la PCTB
RelativeX = MaxX / pctJOY.ScaleWidth
RelativeY = MaxY / pctJOY.ScaleHeight

End Sub

Private Sub Form_Unload(Cancel As Integer)
'Terminaison appli
loopEnd = True

End Sub


Private Sub RunLoop()
Dim X As Long, Y As Long
Dim JoyInformation As JOYINFO

Me.Show

'Boucle primaire de Jeux
Do
pctJOY.Cls
joyGetPos JOYSTICK1, JoyInformation 'Recuperation Etats
X = (JoyInformation.wXpos / RelativeX) - HalflgCurseur 'Recup position
Y = (JoyInformation.wYpos / RelativeY) - HalfhtCurseur
Dim i As Integer

For i = 0 To pctB.Count - 1 'Reset des boutons
    pctB(i).BackColor = &H8000000F
Next i
Call calc(JoyInformation.wButtons) 'Afficahge des bouttons

shCtrlPos.Left = X - shCtrlPos.Width / 2 'Position du shape
shCtrlPos.Top = Y - shCtrlPos.Height / 2
pctJOY.Refresh
DoEvents

Loop Until loopEnd


End Sub

Private Sub calc(nb As Long)
'Fonction pour le mutli-boutonning pour les hardcore gamers :)

Dim incr, temp, i As Long

incr = 1024
temp = 0
i = 11

Do
    If incr <= nb Then
    temp = nb \ incr
    nb = nb - incr
    End If
    
    If CBool(temp) Then pctB(i - 1).BackColor = vbRed
    temp = 0
    incr = incr / 2
    i = i - 1
Loop While incr >= 1

End Sub