Tutoriel Gdi+ : programmez un jeu de Pacman complet en VBA

VII. Préparation du projet VBA▲

La gestion des graphismes, des sons et des commandes nécessite l'ajout de code VBA pour déclarer les fonctions de l'API Windows.

Préparons dans ce chapitre le projet VBA en important les modules VBA nécessaires.

Pour vous placer dans le projet VBA, ouvrez le fichier Excel et tapez ALT + F11.
Ou par le menu : Outils => Macro => Visual Basic Editor.

VII-A. Le graphisme▲

Nous ciblons une version de Windows au moins égale à XP.
Dans le cas contraire, téléchargez les fichiers redistribuables de Gdi+ et placez les fichiers dézippés dans le même répertoire que le classeur Excel.

Nous utilisons le module de classe clGdiplus pour faciliter l'utilisation de gdi+ en VBA.

Téléchargez le module clGdiplus au format texte.
Dans l'éditeur VBA :

Dans le menu : Fichier => Importer un fichier…
Choisir le fichier clGdiPlus.cls téléchargé.
Modifiez la constante de compilation pour une utilisation avec Excel.
Remplacez :
Sélectionnez
```
#Const AppName = "A"
```
Par :
Sélectionnez
```
#Const AppName = "E"
```
La référence à Microsoft Forms 2.0 Object Library est requise.
Vous pouvez ajouter cette référence dans le menu Outils => Références….
Sinon si vous ne la trouvez pas, cette référence sera ajoutée lors de la création d'un UserForm.
Compiler pour vérifier que tout est correct (menu Débogage => Compiler).

VII-B. Les sons▲

Pour jouer des sons, on utilise la fonction mciSendString de la bibliothèque winmm.dll
Créez un module de classe nommé clSound contenant le code suivant :

Code du module de son

Sélectionnez

'***************************************************************************************
'*                             CLASSE POUR SON                                         *
'***************************************************************************************
Option Explicit
            
#If VBA7 Then
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
            (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
            ByVal uReturnLength As Long, ByVal hwndCallback As LongPtr) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
        (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#Else
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
            (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
            ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
        (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#End If
            
'------------------------------------------------
' Ouvre un son
'------------------------------------------------
Public Sub OpenSound(pPath As String, pName As String)
Dim lPath As String
' Récupère le chemin court
lPath = pPath
lPath = Left(lPath, GetShortPathName(pPath, lPath, Len(pPath)))
' Ouvre le fichier son sous l'alias pName
mciSendString "Open " & lPath & " alias " & pName, vbNullString, 0&, 0&
End Sub
            
'------------------------------------------------
' Joue un son
'------------------------------------------------
Public Sub PlaySound(pName As String)
' Joue le son depuis la début
mciSendString "Play " & pName & " From 0", vbNullString, 0&, 0&
End Sub
            
'------------------------------------------------
' Stoppe un son
'------------------------------------------------
Public Sub StopSound(pName As String)
' Stoppe le son
mciSendString "Stop " & pName, vbNullString, 0&, 0&
End Sub
            
'------------------------------------------------
' Ferme un son
'------------------------------------------------
Public Sub CloseSound(pName As String)
' Stoppe le son
mciSendString "Close " & pName, vbNullString, 0&, 0&
End Sub
            
'------------------------------------------------
' Initialisation de la classe
'------------------------------------------------
Private Sub Class_Initialize()
'
End Sub
            
'------------------------------------------------
' Fermeture de la classe
'------------------------------------------------
Private Sub Class_Terminate()
mciSendString "Close All", vbNullString, 0&, 0&
End Sub

Ce module nous permettera de charger les sons en mémoire avec la fonction OpenSound, puis de les jouer avec la fonction PlaySound.

VII-C. Les commandes▲

Créez un nouveau module de classe nommé clCommand contenant le code suivant :

Code du module de commandes

Sélectionnez

'***************************************************************************************
'*                             CLASSE POUR COMMANDES                                   *
'***************************************************************************************
Option Explicit
            
'---------------------------------------------------------------------------------------
' Déclarations pour Joystick
'---------------------------------------------------------------------------------------
#If VBA7 Then
Private Declare PtrSafe Function joyGetNumDevs Lib "winmm.dll" Alias "joyGetNumDev" () As Long
Private Declare PtrSafe Function joyGetPos Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFO) As Long
Private Declare PtrSafe Function joyGetDevCaps Lib "winmm.dll" Alias "joyGetDevCapsA" _
                            (ByVal id As LongPtr, lpCaps As JOYCAPS, ByVal uSize As Long) As Long
Private Declare PtrSafe Function joyGetPosEx Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFOEX) As Long
#Else
Private Declare Function joyGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function joyGetPos Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFO) As Long
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 joyGetPosEx Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFOEX) As Long
#End If
Private Type JOYCAPS
    wMid As Integer
    wPid As Integer
    szPname As String * 32
    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 JOYINFOEX
    dwSize As Long
    dwFlags As Long
    dwXpos As Long
    dwYpos As Long
    dwZpos As Long
    dwRpos As Long
    dwUpos As Long
    dwVpos As Long
    dwButtons As Long
    dwButtonNumber As Long
    dwPOV As Long
    dwReserved1 As Long
    dwReserved2 As Long
End Type
Private Type JOYINFO
    X As Long
    Y As Long
    Z As Long
    Buttons As Long
End Type
Private Const JOY_BUTTON1 = &H1
Private Const JOY_BUTTON2 = &H2
Private Const JOY_BUTTON3 = &H4
Private Const JOY_BUTTON4 = &H8
Private Const JOYERR_BASE = 160
Private Const JOYERR_NOERROR = (0)
Private Const JOYERR_NOCANDO = (JOYERR_BASE + 6)
Private Const JOYERR_PARMS = (JOYERR_BASE + 5)
Private Const JOYERR_UNPLUGGED = (JOYERR_BASE + 7)
Private Const JOY_RETURNX As Long = &H1&
Private Const JOY_RETURNY As Long = &H2&
Private Const JOY_RETURNZ As Long = &H4&
Private Const JOY_RETURNR As Long = &H8&
Private Const JOY_RETURNU As Long = &H10
Private Const JOY_RETURNV As Long = &H20
Private Const JOY_RETURNPOV As Long = &H40&
Private Const JOY_RETURNBUTTONS As Long = &H80&
Private Const JOY_RETURNCENTERED As Long = &H400&
Private Const JOY_RETURNALL As Long = (JOY_RETURNX Or JOY_RETURNY Or JOY_RETURNZ Or JOY_RETURNR _
                        Or JOY_RETURNU Or JOY_RETURNV Or JOY_RETURNPOV Or JOY_RETURNBUTTONS)
            
'---------------------------------------------------------------------------------------
' Déclarations pour clavier
' http://msdn2.microsoft.com/en-us/library/ms646293(VS.85).aspx
'---------------------------------------------------------------------------------------
#If VBA7 Then
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Private Declare Function GetKeyboardState Lib "user32" (lpKeyState As Byte) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
#End If
'---------------------------------------------------------------------------------------
' Variables
'---------------------------------------------------------------------------------------
' Numéro du joypad (0 par défaut)
#If VBA7 Then
Private gJoyPadNum As LongPtr
#Else
Private gJoyPadNum As Long
#End If
'---------------------------------------------------------------------------------------
' Nom du joypad
' Propriété en lecture
'---------------------------------------------------------------------------------------
Public Property Get JoyPadName() As String
Dim lCaps As JOYCAPS
Dim lInfo As JOYINFOEX
' Test si joypad OK
lInfo.dwSize = Len(lInfo)
If joyGetPosEx(gJoyPadNum, lInfo) <> JOYERR_NOERROR Then
    JoyPadName = ""
    Exit Property
End If
' Lecture nom du joypad
joyGetDevCaps gJoyPadNum, lCaps, Len(lCaps)
JoyPadName = Left(lCaps.szPname, InStr(lCaps.szPname, vbNullChar) - 1)
End Property
            
'---------------------------------------------------------------------------------------
' Nombre de boutons du joypad
' Propriété en lecture
'---------------------------------------------------------------------------------------
Public Property Get JoyPadButtons() As Long
Dim lCaps As JOYCAPS
Dim lInfo As JOYINFOEX
' Test si joypad OK
lInfo.dwSize = Len(lInfo)
If joyGetPosEx(gJoyPadNum, lInfo) <> JOYERR_NOERROR Then
    JoyPadButtons = 0
    Exit Property
End If
' Lecture nombre de boutons
joyGetDevCaps gJoyPadNum, lCaps, Len(lCaps)
JoyPadButtons = lCaps.wNumButtons
End Property
            
'---------------------------------------------------------------------------------------
' Numéro du joypad
' Propriété en lecture/écriture
'---------------------------------------------------------------------------------------
Public Property Get JoyPadNum() As Long
JoyPadNum = gJoyPadNum
End Property
Public Property Let JoyPadNum(pJoyPadNum As Long)
gJoyPadNum = pJoyPadNum
End Property
            
'---------------------------------------------------------------------------------------
' Teste quelle touche est appuyée
' Renvoi un seul code de touche même si plusieurs touche sont appuyées
'---------------------------------------------------------------------------------------
Public Function KeyPressGetCode() As Long
Dim lTouches(0 To 255) As Byte
Dim lCpt As Long
GetKeyboardState lTouches(0)
For lCpt = 0 To 255
    If (lTouches(lCpt) And &H80) = &H80 Then
        KeyPressGetCode = lCpt
        Exit For
    End If
Next
End Function
            
'---------------------------------------------------------------------------------------
' Test d'une touche clavier par son code
' Renvoi True si la touche est appuyée
' Si pTime est renseigné, test si la touche a été appuyée pTime ms après
'    le dernier appui testé (quelque soit le code)
'---------------------------------------------------------------------------------------
Public Function TestKey(pKey As Long, Optional pTime As Long) As Boolean
    Static sTime  As Double
    TestKey = (GetAsyncKeyState(pKey) And &H8000)
    If TestKey Then
        If pTime <> 0 Then
            If (Timer - sTime) < (pTime / 1000) Then
                TestKey = False
            Else
                sTime = Timer
            End If
        Else
            sTime = Timer
        End If
    End If
End Function
            
'---------------------------------------------------------------------------------------
' Test d'une direction joypad
' Renvoi True dans le paramètre où la touche de direction est appuyée
' Si pTime est renseigné, test si la touche a été appuyée pTime ms après
'    le dernier appui testé (quelque soit le code)
'---------------------------------------------------------------------------------------
Public Sub TestJoypadDir(Optional pLeft As Boolean, Optional pRight As Boolean, _
                    Optional pUp As Boolean, Optional pDown As Boolean, Optional pTime As Long)
    Static sTime  As Double
    Dim lInfo As JOYINFOEX ' Structure pour lecture de l'état du jostick
    Dim lJoyPresent As Boolean ' Variable pour test si joystick présent
    lInfo.dwSize = Len(lInfo) ' Il est nécessaire d'initialiser cette variable
    lInfo.dwFlags = JOY_RETURNX Or JOY_RETURNY  ' On lit l'état des axes X et Y
    ' Lecture des infos et flag si joystick présent
    lJoyPresent = (joyGetPosEx(gJoyPadNum, lInfo) = JOYERR_NOERROR)
    ' Etat du joypad
    pLeft = (lJoyPresent And lInfo.dwXpos = 0)
    pRight = (lJoyPresent And lInfo.dwXpos = 65535)
    pUp = (lJoyPresent And lInfo.dwYpos = 0)
    pDown = (lJoyPresent And lInfo.dwYpos = 65535)
    If pLeft Or pRight Or pUp Or pDown Then
        If pTime <> 0 Then
            If (Timer - sTime) < (pTime / 1000) Then
                pLeft = False: pRight = False: pUp = False: pDown = False
            Else
                sTime = Timer
            End If
        Else
            sTime = Timer
        End If
    End If
End Sub
            
'---------------------------------------------------------------------------------------
' Test d'un bouton du joypad
' Renvoi True si le bouton n° NbButton est appuyé
' Si pTime est renseigné, test si la touche a été appuyée pTime ms après
'    le dernier appui testé (quelque soit le code)
'---------------------------------------------------------------------------------------
Public Function TestJoypadButton(pNbButton As Long, Optional pTime As Long) As Boolean
    Static sTime  As Double
    Dim lInfo As JOYINFOEX ' Structure pour lecture de l'état du jostick
    Dim lJoyPresent As Boolean ' Variable pour test si joystick présent
    lInfo.dwSize = Len(lInfo) ' Il est nécessaire d'initialiser cette variable
    lInfo.dwFlags = JOY_RETURNBUTTONS  ' On lit l'état des boutons
    ' Lecture des infos et flag si joystick présent
    lJoyPresent = (joyGetPosEx(gJoyPadNum, lInfo) = JOYERR_NOERROR)
    ' Etat du bouton du joypad
    TestJoypadButton = (lJoyPresent And (lInfo.dwButtons And 2 ^ pNbButton) = 2 ^ pNbButton)
    If TestJoypadButton Then
        If pTime <> 0 Then
            If (Timer - sTime) < (pTime / 1000) Then
                TestJoypadButton = False
            Else
                sTime = Timer
            End If
        Else
            sTime = Timer
        End If
    End If
End Function

Ce module contient les fonctions nécessaires à la détection des commandes (clavier ou joypad).

VII-D. La minuterie▲

Le module clGdiplus intègre déjà une procédure Wait pour gérer une minuterie.

VII-E. Le formulaire principal▲

Créez un nouveau formulaire : Insertion => Userform.
Renommez-le en FormGame.

Si nécessaire, affichez la boîte à outils (Affichage => Boîte à outils).
Choisissez le contrôle image dans la boîte à outils et placez une image sur le formulaire.
Renommez cette image (propriété name) pour lui donner le nom img.
Le jeu s'affichera dans cette image, donnez lui une taille raisonnable.

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Thierry GASPERMENT. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts. Droits de diffusion permanents accordés à Developpez LLC.