Soyez le premier à donner votre avis sur cette source.
Vue 12 135 fois - Téléchargée 1 215 fois
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
Merci beaucoup.
Merci beaucoup
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.