I. Introduction

Dans le tome 1, nous avons étudié les bases de la programmation d'EXCEL en VBA. Ce tome 2 est consacré à une partie plus ludique : la programmation en mode graphique.

Mais pourquoi programmer en mode graphique ? Imaginez que vous puissiez maîtriser chacun des pixels de votre écran, afficher des images, gérer des animations… Vous devinez toute la richesse qu'une programmation en mode graphique peut vous apporter. Certes, pas dans une application ordinaire, mais pour un jeu d'arcade, c'est l'outil idéal qui vous manquait pour laisser libre cours à votre imagination.

Autant le savoir dès maintenant, le VBA n'a pas les fonctions nécessaires pour une programmation en mode graphique. Nous allons donc faire appel aux API que nous avons déjà évoquées dans le tome 1 :

« Les API, Application Programming Interface, sont des ensembles de classes, de méthodes ou de fonctions, mises gratuitement à disposition des développeurs par les éditeurs de services, de logiciels ou d'applications. Les développeurs en feront usage pour intégrer certaines fonctionnalités à leurs applications. »

Nous allons étudier les bases de la programmation en mode graphique en utilisant les principales API dédiées au mode graphique. Ces bases vous permettront de développer des applications simples, voire votre premier jeu d'arcade.

Exercice plus délicat qu'il n'y paraît, car vous devrez à la fois interagir avec les interventions du joueur et afficher un maximum d'images pour une bonne esthétique, le tout en préservant la fluidité du jeu.

De solides notions de programmation en VBA vous seront nécessaires. Si ce n'est pas le cas, je vous invite à approfondir vos connaissances en lisant le tome 1, qui vous apportera le niveau requis.

Nous faisons référence dans ce document aux API Windows compatibles avec la version EXCEL 32 bits. Pour plus d'information sur la compatibilité des API sous EXCEL 64 bits, je vous invite à lire l'excellente documentation de Thierry Gasperment : Développer avec Office 64 bits. Les codes sources ont été testés avec EXCEL 2000 sous XP, EXCEL 2010 sous Windows 7, EXCEL 2016 sous Windows 10.

Vous retrouverez le détail de ces API et de nombreux exemples sur le site « http://allapi.mentalis.org/apilist/apilist.php ».

II. Les API de base pour la programmation en mode graphique

La première API que nous utiliserons est GetWindowDC qui retourne dans un entier long le « contexte de périphérique » (Device Context) de l'écran. Par convention nous le noterons Hdc.

Pour bien comprendre, représentez-vous l'écran comme étant l'équivalent d'une image (Bitmap) composée de pixels de couleurs différentes. Le contexte pointe vers cette image chargée en mémoire que nous pouvons maintenant manipuler pixel par pixel.

Ainsi, pour écrire à l'écran un pixel aux coordonnées X, Y on utilise l'API SetPixel(Hdc, X, Y, Couleur).

Inversement, pour connaître la couleur d'un pixel aux coordonnées X,Y on utilise l'API GetPixel(Hdc, X, Y).

Vous remarquerez que les API que nous utiliserons expriment les coordonnées d'un pixel au format (X, Y), contrairement aux fonctions du VBA qui expriment les coordonnées d'une cellule au format (Y, X). Et l'origine d'une image est le pixel 0, 0 contrairement au VBA où l'origine d'une feuille est la cellule 1, 1.

Vous en savez désormais assez pour programmer en mode graphique cet exemple où l'on trace un trait de la position 0, 100 à la position 300, 100 en utilisant la couleur du point haut gauche de l'écran (0, 0) :

 
Sélectionnez
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function SetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, _
                                       ByVal crColor As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Recherche la couleur du pixel aux coordonnées 0,0 de l'écran:
Couleur = GetPixel(Hdc, 0, 0)

' Dessine avec cette couleur les 301 premiers pixels de la ligne 100:
For X = 0 To 300
    Call SetPixel(Hdc, X, 100, Couleur)
Next X

' Libère le buffer utilisé pour atteindre l'écran:
ReleaseDC 0, Hdc

End Sub

La mémoire utilisée pour gérer le contexte de l'écran est libérée par l'API ReleaseDC.

Il y a plus rapide pour tracer une droite, en utilisant dans un premier temps l'API MoveToEx(Hdc, X, Y) pour indiquer les coordonnées du point d'origine, puis LineTo(Hdc, X, Y) pour tracer une droite de ce point jusqu'au point de destination.

La ligne est tracée avec le style, la taille et la couleur par défaut. Vous pouvez paramétrer ces valeurs, avec l'API CreatePen(Style, Taille, Couleur), puis sélectionner ce nouveau modèle avec l'API SelectObject(Hdc, Objet). Le modèle créé est libéré de la mémoire avec l'API DeleteObject(Objet).

Le style du trait peut prendre les valeurs suivantes : 0 trait continu, 1 pointillé, 2 parsemé, 3 alternant traits et points, 4 alternant traits et points doubles.

 
Sélectionnez
Declare Function MoveToEx Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, _
                                       ByVal Y As Long, lpPoint As POINT) As Long
Declare Function LineTo Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, _ 
                                        ByVal crColor As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Type POINT
    X As Long
    Y As Long
End Type
Dim PointXY As POINT

Sub NotionsDeBase()

Dim ObjetPen As Long

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création de l'objet crayon qui détermine le style, l'épaisseur et la couleur d'une ligne
' Ici Style = 0 (trait continu), Taille = 1, Couleur = 150000 (rouge):
ObjetPen = CreatePen(0, 1, 150000)
Call SelectObject(Hdc, ObjetPen)

' Active la position 0, 100 (avec PointXY est null):
MoveToEx Hdc, 0, 100, PointXY

' Trace la ligne de la position active à la position 300, 100:
LineTo Hdc, 300, 100

' Efface l'object Crayon de la mémoire:
DeleteObject ObjetPen

' Libère le buffer utilisé pour atteindre l'écran
ReleaseDC 0, Hdc

End Sub

Le dernier point devenant le nouveau point d'origine, cette technique permet de dessiner un polygone vide, c'est-à-dire sans couleur de fond. Exemple pour dessiner un rectangle vide identifié par les coordonnées des angles opposés X1, Y1 à X2, Y2 :

 
Sélectionnez
MoveToEx Hdc, X1, Y1, PointXY
LineTo Hdc, X2, Y1
LineTo Hdc, X2, Y2
LineTo Hdc, X1, Y2
LineTo Hdc, X1, Y1

Pour dessiner un rectangle plein, nous utilisons les API CreateSolidBrush(Couleur) pour définir la couleur de fond de remplissage puis Rectangle(Hdc, X1, Y1, X2, Y2).

Pour tout autre polygone plein, nous utilisons l'API Polygon(Hdc, ListeDesPoints, NombreDePoints).

L'API CreateHatchBrush(Style, Couleur) est plus complète que CreateSolidBrush(Couleur) car elle permet de définir, en plus de la couleur de remplissage, le style de remplissage qui peut avoir les valeurs suivantes : 0 traits horizontaux, 1 traits verticaux, 2 traits inclinés de gauche à droite, 3 traits inclinés de droite à gauche, 4 quadrillage, 5 quadrillage incliné, 6 remplissage plein.

 
Sélectionnez
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function Rectangle Lib "gdi32" _
                 (ByVal Hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, _
                  ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function Polygon Lib "gdi32" _
                 (ByVal Hdc As Long, lpPoint As POINT, ByVal nCount As Long) As Long
Declare Function CreateHatchBrush Lib "gdi32" _
                 (ByVal nIndex As Long, ByVal crColor As Long) As Long


Sub xNotionsDeBase()


Dim ObjetBrush As Long
Dim ObjetHatchBrush As Long
Dim ObjetPen As Long
Dim PointXY(1 To 3) As POINT

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création de l'objet Brush qui détermine la couleur de remplissage.
' Ici Couleur = 15000 (rouge)
ObjetBrush = CreateSolidBrush(15000)
Call SelectObject(Hdc, ObjetBrush)

' Dessine un rectangle aux coordonnées X1, Y1, X2, Y2:
X1 = 100: Y1 = 100: X2 = 200: Y2 = 200
Call Rectangle(hdc, X1, Y1, X2, Y2)

' Création de l'objet HatchBrush qui détermine le style et la couleur de remplissage.
' Ici Style = 4 (quadrillage), Couleur = 15000 (rouge)
ObjetHatchBrush = CreateHatchBrush(4, 15000)
Call SelectObject(Hdc, ObjetHatchBrush)

' Création de l'objet Pen qui détermine le style du trait, son épaisseur, et sa couleur.
' Ici Style = 2 (pointillé), Taille = 1 (fine), Couleur = 0 (noir)
ObjetPen = CreatePen(2, 1, 0)
Call SelectObject(Hdc, ObjetPen)

' Dessine un Polygone (ici un triangle) aux coordonnées X1, Y1, X2, Y2, X3, Y3:
X1 = 100: Y1 = 400: X2 = 200: Y2 = 500: X3 = X1: Y3 = Y2
PointXY(1).X = X1: PointXY(1).Y = Y1
PointXY(2).X = X2: PointXY(2).Y = Y2
PointXY(3).X = X3: PointXY(3).Y = Y3
Call Polygon(Hdc, PointXY(1), 3)

' Efface les objets de la mémoire:
DeleteObject ObjetBrush
DeleteObject ObjetHatchBrush
DeleteObject ObjetPen

' Libère le buffer utilisé pour atteindre l'écran:
ReleaseDC 0, Hdc

End Sub

Pour écrire du texte, nous disposons de plusieurs API. La rustique TextOut(Hdc, X, Y, Texte, NombreDeCaractères) me semble la plus rapide d'exécution, c'est pourquoi je l'ai retenue.

La configuration des paramètres par défaut utilisés par TextOut se fait avec les API suivantes :

  • L'API SetTextColor(Hdc, Couleur) pour définir la couleur du texte ;
  • L'API SetBkColor(Hdc, Couleur) pour définir la couleur de fond ;
  • L'API CreateFont permet de définir les 14 paramètres de la police utilisée. Les plus utiles sont : font_height qui détermine la taille de la police, weight pour l'épaisseur (de 100 fin, à 900 gras), italic pour mettre en italique (1 pour vrai), underscore pour souligner (1 pour vrai), face_name pour le nom de la police.

Nous utilisons la fonction QBColor du VBA pour convertir une couleur de l'ancien système 16 couleurs (0 Noir, 1 Bleu, 2 Vert, 3 Cyan, 4 Rouge, 5 Magenta, 6 jaune, 7 Blanc, 8 Gris, 9 Bleu clair, 10 Vert clair, 11 Cyan clair, 12 Rouge clair, 13 Magenta clair, 14 Jaune clair, 15 Blanc brillant) au système RVB de 16 millions de couleurs.

 
Sélectionnez
Declare Function SetTextColor Lib "gdi32" (ByVal Hdc As Long, ByVal crColor As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal Hdc As Long, ByVal crColor As Long) As Long
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
    (ByVal font_height As Long, ByVal font_width As Long, ByVal escapement As Long, _
    ByVal Orientation As Long, ByVal weight As Long, ByVal italic As Long, _
    ByVal underscore As Long, ByVal strikeout As Long, ByVal character_set As Long, _
    ByVal output_precision As Long, ByVal clipping_precision As Long, ByVal quality As Long, _
    ByVal pitch_and_family As Long, ByVal face_name As String) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
    (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, _
    ByVal nCount As Long) As Long

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

Call SetTextColor(Hdc, QBColor(15)) ' Couleur Basic du texte 15 = Blanc
Call SetBkColor(Hdc, QBColor(0))    ' Couleur Basic du fond 0 = Noir

' Création d'un objet qui détermine les propriétés de l'écriture:
Dim ObjetFont As Long
ObjetFont = CreateFont(20, 0, 0, 0, 900, 0, 1, 0, 0, 0, 0, 0, 0, "Arial")
Call SelectObject(Hdc, ObjetFont)

' Affiche le texte sur 15 caractères en haut à gauche (origine 0, 0):
Call TextOut(Hdc, 0, 0, "Démonstration :", 15)

' Libère le buffer utilisé pour atteindre l'écran:
ReleaseDC 0, Hdc

End Sub

Nous verrons plus tard comment écrire en transparence.

III. Gérer les mémoires écran

Jusqu'à présent nous avons travaillé directement sur l'écran, en utilisant le contexte de l'écran. Mais dans la pratique, il ne faut pas faire comme cela, car les temps de mise à jour de l'écran sont trop longs et provoquent des saccades. Vous comprendrez pourquoi plus tard.

Pour des traitements plus rapides, nous allons générer une mémoire compatible avec le format de l'écran, c'est-à-dire un nouveau contexte, y faire une copie de l'écran, travailler dans cette mémoire, puis afficher à l'écran cette mémoire.

Pour cela nous utilisons les nouvelles API suivantes :

  • GetSystemMetrics(Index) pour connaître la largeur et la hauteur de l'écran ;
  • CreateCompatibleBitmap(Hdc, Largeur, Hauteur) pour créer une mémoire au format Bitmap de l'écran, de la taille désirée ;
  • CreateCompatibleDC(Hdc) pour créer un nouveau contexte compatible avec le format de l'écran ;
  • BitBlt(HdcDestination, X, Y, Largeur, Hauteur, HdcSource, XSource, YSource, Mode) pour copier dans le contexte HdcDestination en position X, Y sur une largeur et une hauteur, le contenu du contexte source d'origine XSource, YSource ;
  • DeleteDC(Hdc) libère, de la mémoire, le contexte créé.

L'exemple suivant permet d'inverser l'écran. Pour cela, nous mémorisons l'écran dans une première mémoire, puis nous créons une deuxième mémoire, vide, qui sera alimentée des pixels inversés, ceux de gauche allant à droite, ceux d'en haut allant en bas. Cette mémoire sera affichée à l'écran 5 secondes, puis la mémoire d'origine sera affichée.

 
Sélectionnez
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal Hdc As Long, ByVal nWidth As Long, _
                                                     ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal Hdc As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
        ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function SetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, _
                                       ByVal crColor As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const SRCCOPY = &HCC0020

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Recherche la résolution de l'écran:
ImgMaxiX = GetSystemMetrics(0) ' Taille verticale
ImgMaxiY = GetSystemMetrics(1) ' Taille horizontale

' Création d'une mémoire (compatible écran) de taille de l'écran:
Dim ImgEcran_Img As Variant
Dim ImgEcran_Hdc As Long
Dim ImgEcran_Obj As Long

ImgEcran_Img = CreateCompatibleBitmap(Hdc, ImgMaxiX, ImgMaxiY)
ImgEcran_Hdc = CreateCompatibleDC(Hdc)
ImgEcran_Obj = SelectObject(ImgEcran_Hdc, ImgEcran_Img)

' Copie l'intégralité de l'écran dans cette mémoire:
BitBlt ImgEcran_Hdc, 0, 0, ImgMaxiX, ImgMaxiY, Hdc, 0, 0, SRCCOPY

' Création d'une 2e mémoire (compatible écran) de la taille de l'écran:
Dim Tps_Img As Variant
Dim Tps_Hdc As Long
Dim Tps_Obj As Long

Tps_Img = CreateCompatibleBitmap(Hdc, ImgMaxiX, ImgMaxiY)
Tps_Hdc = CreateCompatibleDC(Hdc)
Tps_Obj = SelectObject(Tps_Hdc, Tps_Img)

' Inverse les pixels horizontaux et verticaux:
For X = 0 To ImgMaxiX
    For Y = 0 To ImgMaxiY
        Couleur = GetPixel(ImgEcran_Hdc, X, Y)
        Call SetPixel(Tps_Hdc, ImgMaxiX - X, ImgMaxiY - Y, Couleur)
    Next Y
Next X

' Affiche cette mémoire à l'écran:
BitBlt Hdc, 0, 0, ImgMaxiX, ImgMaxiY, Tps_Hdc, 0, 0, SRCCOPY

' Attente de cinq secondes:
Call Sleep(5000)

' Affiche la mémoire d'origine de l'écran:
BitBlt Hdc, 0, 0, ImgMaxiX, ImgMaxiY, ImgEcran_Hdc, 0, 0, SRCCOPY

' Libère les mémoires:
DeleteObject SelectObject(ImgEcran_Hdc, ImgEcran_Obj)
DeleteDC ImgEcran_Hdc
DeleteObject SelectObject(Tps_Hdc, Tps_Obj)
DeleteDC Tps_Hdc

' Libère le buffer écran:
ReleaseDC 0, Hdc
End Sub

Remarques sur l'utilisation de BitBlt (HdcDestination, X, Y, Largeur, Hauteur, HdcSource, XSource, YSource, Mode) : la taille de l'image source à copier est définie dans les arguments Largeur et Hauteur. Le point d'origine (haut, gauche) de l'image source est défini par les arguments XSource et YSource, qui ne valent pas forcément 0. Vous pouvez donc ne copier qu'une fraction de l'image source. De même, l'image n'est pas forcément copiée dans le contexte de destination au point 0, 0 (haut, gauche). Vous pouvez donc copier l'image source n'importe où dans le contexte de destination grâce aux arguments X et Y. Enfin, il s'agit bien d'une copie et non d'un transfert, la source reste donc inchangée.

En résumé : pour faire une copie d'écran dans une mémoire, HdcSource est le contexte de l'écran et HdcDestination est le contexte de la mémoire. Inversement, pour afficher à l'écran une mémoire, HdcSource est le contexte de la mémoire et HdcDestination est le contexte de l'écran.

Il existe une autre API pour copier une image, semblable à BitBlt, un peu plus longue en temps de traitement, mais qui sait gérer la couleur de transparence. C'est l'API GdiTransparentBlt (HdcDestination, X, Y, Largeur, Hauteur, HdcSource, XSource, YSource, LargeurSource, HauteurSource, CouleurDeTransparence)

Nous allons l'utiliser pour écrire un texte en transparence.

IV. Écrire un texte en transparence

Pour écrire un texte en transparence, nous créons dans un premier temps une mémoire de la taille du texte à écrire. Cette mémoire, vide, est initialisée avec des pixels à 0. Puis nous y déposons le texte désiré après avoir pris soin de définir la couleur 0 comme couleur de fond. Enfin, nous copions cette mémoire à l'écran via l'API GdiTransparentBlt en déclarant la couleur 0 comme couleur de transparence.

Cette méthode donne des résultats plus esthétiques que l'écriture sur fond opaque, mais est plus longue en temps de traitement.

Cet exemple montre comment écrire un texte de 15 caractères en police Arial de taille 20 :

 
Sélectionnez
Declare Function GdiTransparentBlt Lib "gdi32.dll" (ByVal Hdc As Long, ByVal X As Long, _
        ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
        ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
        ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création d'une mémoire (compatible écran) de taille du texte = 20 pixels x 15 caractères:
Dim ImgEcran_Img As Variant
Dim ImgEcran_Hdc As Long
Dim ImgEcran_Obj As Long

ImgEcran_Img = CreateCompatibleBitmap(Hdc, 20 * 15, 20)
ImgEcran_Hdc = CreateCompatibleDC(Hdc)
ImgEcran_Obj = SelectObject(ImgEcran_Hdc, ImgEcran_Img)

' Définition de la couleur du texte et de la couleur de fond (pour ce nouveau contexte):
Call SetTextColor(ImgEcran_Hdc, 10)  ' Couleur texte 10 = Noir
Call SetBkColor(ImgEcran_Hdc, 0)     ' Couleur du fond 0

' Création d'un objet qui détermine les propriétés de l'écriture (pour ce nouveau contexte):
Dim ObjetFont As Long
ObjetFont = CreateFont(20, 0, 0, 0, 900, 0, 0, 0, 0, 0, 0, 0, 0, "Arial")
Call SelectObject(ImgEcran_Hdc, ObjetFont)

' Écrit le texte sur 15 caractères dans cette mémoire, et non pas à l'écran:
Call TextOut(ImgEcran_Hdc, 0, 0, "Démonstration :", 15)

' Copie cette mémoire dans l'écran en 100, 400, avec 0 en couleur de transparence:
Call GdiTransparentBlt(Hdc, 100, 400, 20 * 15, 20, ImgEcran_Hdc, 0, 0, 20 * 15, 20, 0)

' Libère les mémoires:
DeleteObject SelectObject(ImgEcran_Hdc, ImgEcran_Obj)
DeleteDC ImgEcran_Hdc
DeleteObject ObjetFont

' Libère le buffer écran:
ReleaseDC 0, Hdc
End Sub

V. Gérer une image issue d'un fichier BMP

La fonction VBA LoadPicture permet de charger une image Bitmap BMP, compatible au format écran. Elle se substitue alors à l'API CreateCompatibleBitmap.

L'API GetObjectAPI permet de lire le format du fichier Bitmap BMP et de connaître ses dimensions qui nous seront utiles pour copier l'image.

L'exemple ci-dessus charge en mémoire une image BMP représentant une pomme, et obtient un nouveau contexte de périphérique qui permettra de manipuler cette mémoire (et non pas le fichier).

La couleur du point d'origine de l'image est considérée comme la couleur de transparence à utiliser pour afficher l'image.

 
Sélectionnez
Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
    (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Type Bitmap
      bmType As Long
      bmWidth As Long
      bmHeight As Long
      bmWidthBytes As Long
      bmPlanes As Integer
      bmBitsPixel As Integer
      bmBits As Long
End Type

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création d'une mémoire (compatible écran):
Dim ImgFichier_Img As Variant
Dim ImgFichier_Hdc As Long
Dim ImgFichier_Obj As Long

' Charge l'image et crée une mémoire compatible au format de l'écran:
Set ImgFichier_Img = LoadPicture("C:\_Formation_VBA\Pomme.bmp")
ImgFichier_Hdc = CreateCompatibleDC(Hdc)
ImgFichier_Obj = SelectObject(ImgFichier_Hdc, ImgFichier_Img)

' Récupère le bitmap de l'image pour connaître la taille de l'image:
Dim Bitmap_BMP As Bitmap
Call GetObjectAPI(ImgFichier_Img.handle, Len(Bitmap_BMP), Bitmap_BMP)

' Récupére la couleur de transparence de l'image (couleur de son point d'origine 0,0):
CouleurTransparence = GetPixel(ImgFichier_Hdc, 0, 0)

' Copie cette mémoire dans l'écran en 100, 100, en utilisant la couleur de transparence:
Call GdiTransparentBlt(Hdc, 100, 100, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, ImgFichier_Hdc, _
                       0, 0, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, CouleurTransparence)

' Libère les mémoires:
DeleteObject SelectObject(ImgFichier_Hdc, ImgFichier_Obj)
DeleteDC ImgFichier_Hdc
ReleaseDC 0, Hdc

End Sub

VI. Modifier la taille d'une image

L'API StretchBlt(HdcDestination, X, Y, Largeur, Hauteur, HdcSouce, XSource, YSource, LargeurSource, HauteurSource, Mode) permet de transformer les dimensions d'une image. Une image temporaire est utilisée pour gérer cette transformation et restituer l'image d'origine avec ses nouvelles dimensions.

 
Sélectionnez
Declare Function StretchBlt Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création d'une mémoire (compatible écran):
Dim ImgFichier_Img As Variant
Dim ImgFichier_Hdc As Long
Dim ImgFichier_Obj As Long

' Charge l'image et crée une mémoire compatible au format de l'écran:
Set ImgFichier_Img = LoadPicture("C:\_Formation_VBA\Pomme.bmp")
ImgFichier_Hdc = CreateCompatibleDC(Hdc)
ImgFichier_Obj = SelectObject(ImgFichier_Hdc, ImgFichier_Img)

' Récupére la couleur de transparence de l'image (couleur de son point d'origine 0,0):
CouleurTransparence = GetPixel(ImgFichier_Hdc, 0, 0)

' Définition des nouvelles dimensions:
Lg = 50: Ht = 50

' Création d'une mémoire temporaire (compatible écran) de taille 50 x 50:
Dim TpsImg_Img As Variant
Dim TpsImg_Hdc As Long
Dim TpsImg_Obj As Long

TpsImg_Img = CreateCompatibleBitmap(Hdc, Lg, Ht)
TpsImg_Hdc = CreateCompatibleDC(Hdc)
TpsImg_Obj = SelectObject(TpsImg_Hdc, TpsImg_Img)

' Alimente la mémoire temporaire de l'image d'origine 26 x 26 avec sa taille modifiée:
StretchBlt TpsImg_Hdc, 0, 0, Lg, Ht, ImgFichier_Hdc, 0, 0, 26, 26, SRCCOPY

' Efface la mémoire de l'image d'origine:
DeleteObject SelectObject(ImgFichier_Hdc, ImgFichier_Obj)
DeleteDC ImgFichier_Hdc

' Création d'une nouvelle mémoire avec les nouvelles dimensions:
ImgFichier_Img = CreateCompatibleBitmap(Hdc, Lg, Ht)
ImgFichier_Hdc = CreateCompatibleDC(Hdc)
ImgFichier_Obj = SelectObject(ImgFichier_Hdc, ImgFichier_Img)

Call BitBlt(ImgFichier_Hdc, 0, 0, Lg, Ht, TpsImg_Hdc, 0, 0, SRCCOPY)

' Affiche à l'écran la mémoire avec ses nouvelles dimensions:
Call GdiTransparentBlt(Hdc, 100, 100, Lg, Ht, ImgFichier_Hdc, 0, 0, Lg, Ht, CouleurTransparence)

' Libère les mémoires:
DeleteObject SelectObject(ImgFichier_Hdc, ImgFichier_Obj)
DeleteDC ImgFichier_Hdc
ReleaseDC 0, Hdc

End Sub

VII. Animation de base : déplacer une image à l'écran

Nous avons suffisamment d'outils graphiques pour une première animation, qui consiste à déplacer une image à l'écran. Reprenons l'image de la pomme que nous venons d'afficher dans l'exemple précédent. D'après les principes de Newton, cette pomme attirée par la gravité est censée tomber au sol, soit au bas de l'écran. Mais avant de la déplacer, il faudra effacer l'ancienne position, sans quoi il va y avoir plusieurs pommes d'affichées.

Nous allons donc procéder en plusieurs étapes. Mémoriser l'écran où sera affichée la pomme. Afficher la pomme. Faire une pause. Afficher l'écran mémorisé sans la pomme. Déplacer la pomme. Recommencer.

 
Sélectionnez
Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Création d'une mémoire (compatible écran):
Dim ImgFichier_Img As Variant
Dim ImgFichier_Hdc As Long
Dim ImgFichier_Obj As Long

' Charge l'image et crée une mémoire compatible au format de l'écran:
Set ImgFichier_Img = LoadPicture("C:\_Formation_VBA\Pomme.bmp")
ImgFichier_Hdc = CreateCompatibleDC(Hdc)
ImgFichier_Obj = SelectObject(ImgFichier_Hdc, ImgFichier_Img)

' Récupère le bitmap de l'image pour connaître la taille de l'image:
Dim Bitmap_BMP As Bitmap
Call GetObjectAPI(ImgFichier_Img.handle, Len(Bitmap_BMP), Bitmap_BMP)

' Récupére la couleur de transparence de l'image (couleur de son point d'origine 0,0):
CouleurTransparence = GetPixel(ImgFichier_Hdc, 0, 0)

' Création d'une nouvelle mémoire de la taille de la pomme:
Dim Tps_Img As Variant
Dim Tps_Hdc As Long
Dim Tps_Obj As Long

Tps_Img = CreateCompatibleBitmap(Hdc, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight)
Tps_Hdc = CreateCompatibleDC(Hdc)
Tps_Obj = SelectObject(Tps_Hdc, Tps_Img)

' Boucle sur la position Y de la pomme en incrémentant de 10 pixels la descente de la pomme:
For Y = 100 To GetSystemMetrics(1) Step 10
    
    ' Mémorise l'écran  sera affichée la pomme:
    Call BitBlt(Tps_Hdc, 0, 0, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, Hdc, 100, Y, SRCCOPY)
    
    ' Affiche la pomme à l'écran en 100, Y, en utilisant la couleur de transparence:
    Call GdiTransparentBlt(Hdc, 100, Y, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, _
         ImgFichier_Hdc, 0, 0, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, CouleurTransparence)
         
    ' Fait une pause:
    Call Sleep(50)
        
    ' Affiche l'écran d'origine:
    Call BitBlt(Hdc, 100, Y, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, Tps_Hdc, 0, 0, SRCCOPY)
        
Next Y

' Libère les mémoires:
DeleteObject SelectObject(ImgFichier_Hdc, ImgFichier_Obj)
DeleteDC ImgFichier_Hdc
DeleteObject SelectObject(Tps_Hdc, Tps_Obj)
DeleteDC Tps_Hdc
ReleaseDC 0, Hdc

End Sub

Ça marche, mais déception, l'animation est saccadée, et surtout ça clignote. Ce qui est très désagréable.
C'est normal, je vous avais prévenu qu'il ne fallait pas travailler directement sur le contexte de l'écran, car les temps de traitement sont longs, mais passer par une mémoire de travail, travailler dedans, puis l'afficher.

Une fois l'écran d'origine mémorisé, les étapes deviennent : copier en mémoire de travail cet écran d'origine. Y copier ensuite la pomme. Afficher cette mémoire de travail. Déplacer la pomme. Recommencer.

Reprenons le code. Avant la boucle, nous créons une mémoire de la taille de l'écran et nous y copions l'écran d'origine :

 
Sélectionnez
Ecran_Img = CreateCompatibleBitmap(Hdc, GetSystemMetrics(0), GetSystemMetrics(1))
Ecran_Hdc = CreateCompatibleDC(Hdc)
Ecran_Obj = SelectObject(Ecran_Hdc, Ecran_Img)

Call BitBlt(Ecran_Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), Hdc, 0, 0, SRCCOPY)

Nous créons aussi une mémoire de travail de la taille de l'écran :

 
Sélectionnez
Travail_Img = CreateCompatibleBitmap(Hdc, GetSystemMetrics(0), GetSystemMetrics(0))
Travail_Hdc = CreateCompatibleDC(Hdc)
Travail_Obj = SelectObject(Travail_Hdc, Travail_Img)

Dans la boucle, lorsque nous copierons l'écran d'origine en mémoire de travail, nous utiliserons la mémoire d'origine de l'écran et non plus le contexte de l'écran.
La pomme ne sera plus copiée à l'écran, mais dans la mémoire de travail.
Puis cette mémoire de travail sera affichée à l'écran.

Cela permet de ne faire qu'un appel au contexte de l'écran et non plus trois, d'où un gain de temps dans les traitements qui s'explique facilement, car l'accès aux mémoires est bien plus rapide que l'accès à l'écran. On peut aussi réduire la pause pour éliminer l'effet saccadé.

Le code complet de la boucle devient :

 
Sélectionnez
' Boucle sur la position Y de la pomme en incrémentant de 10 pixels la descente de la pomme:
For Y = 100 To GetSystemMetrics(1) Step 10
    
    ' Copie l'écran d'origine en mémoire de travail:
    Call BitBlt(Travail_Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), Ecran_Hdc, 0, 0, SRCCOPY)
    
    ' Copie la pomme en mémoire de travail en 100, Y, en utilisant la couleur de transparence:
    Call GdiTransparentBlt(Travail_Hdc, 100, Y, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, _
         ImgFichier_Hdc, 0, 0, Bitmap_BMP.bmWidth, Bitmap_BMP.bmHeight, CouleurTransparence)
         
    ' Affiche à l'écran la mémoire de travail:
    Call BitBlt(Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), Travail_Hdc, 0, 0, SRCCOPY)
    
    ' Fait une pause:
    Call Sleep(40)
    
Next Y

Assimilez bien cette gestion des mémoires des images, car nous en aurons besoin par la suite.

VIII. Animation d'un Sprite

Illustrer une pomme qui tombe ne nécessite qu'une image. Il en est autrement pour le vol d'un oiseau. Comme pour un dessin animé, nous avons besoin d'enchaîner différentes images qui décomposent le battement des ailes. C'est ce que nous appelons un Sprite.

J'ai récupéré sur « http://linuxfr.org/users/julien_jorge/journaux/outils-autour-de-gimp-pack-my-sprites-et-xcftools » celui du vol d'un canard. Après retraitement j'ai obtenu huit fichiers BMP de 75 x 84 pixels nommés Vol1 à Vol8, avec 0 en couleur de fond. Pour un cycle d'animation complet, il faudra afficher les images 1 à 8 puis 7 à 1 :

Image non disponible

Le code est semblable à celui étudié pour le déplacement de la pomme, car le principe est le même. Seule évolution, l'image à afficher n'est plus toujours la même et il faut boucler sur la liste des images qui composent le cycle d'animation.

Huit mémoires image devront donc être créées, en plus de la mémoire de l'écran d'origine et de la mémoire de travail. Alors pour simplifier le code, nous allons utiliser un type personnalisé dimensionné de -1 à 8, où les images du Sprite du vol seront notées 1 à 8. L'image 0 sera la mémorisation de l'écran d'origine, et l'image -1 sera notre image de travail.

Pour vérifier la rapidité du traitement, nous allons afficher trois canards en même temps…

 
Sélectionnez
Type TypeImage
    Img As Variant
    Hdc As Long
    Obj As Long
End Type

Type TypeCanard
    X As Long
    Y As Long
    IndiceImage As Integer
End Type

Sub NotionsDeBase()

' Récupère le contexte de l'écran:
Hdc = GetWindowDC(0)

' Initisalisation du nombre de mémoire image qui seront utilisées:
Dim Image(-1 To 8) As TypeImage

' Initialise les mémoires -1 (de travail) et 0 (écran d'origine):
For i = -1 To 0
    Image(i).Img = CreateCompatibleBitmap(Hdc, GetSystemMetrics(0), GetSystemMetrics(1))
    Image(i).Hdc = CreateCompatibleDC(Hdc)
    Image(i).Obj = SelectObject(Image(i).Hdc, Image(i).Img)
Next i

' Charge les 8 images des canards dans les mémoires 1 à 8:
For i = 1 To 8
    Set Image(i).Img = LoadPicture("C:\_Formation_VBA\Vol" & i & ".bmp")
    Image(i).Hdc = CreateCompatibleDC(Hdc)
    Image(i).Obj = SelectObject(Image(i).Hdc, Image(i).Img)
Next i

' Création de la liste d'ordre d'affichage des images pour un cycle complet:
ListeImages = Array("1", "2", "3", "4", "5", "6", "7", "8", "7", "6", "5", "4", "3", "2", "1")

' Mémorise l'écran d'origine en mémoire 0:
Call BitBlt(Image(0).Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), Hdc, 0, 0, SRCCOPY)

' Initialisation de la position des canards de façon aléatoire:
Dim Canard(1 To 3) As TypeCanard
For i = 1 To 3
    Call Randomize(Timer)                 ' Générateur aléatoire
    Canard(i).X = -100 + Rnd() * 100      ' Position horizontale
    Canard(i).Y = Rnd() * 200             ' Position verticale
    Canard(i).IndiceImage = Rnd() * 14    ' Image du vol
Next i

' Boucle tant qu'il reste un canard à l'écran, en incrémentant de 10 pixels vers la droite:
Do
    
    ' Copie de la mémorisation de l'écran (mémoire 0) en mémoire de travail (mémoire -1):
    Call BitBlt(Image(-1).Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), _
                Image(0).Hdc, 0, 0, SRCCOPY)
    
    ' Déplace les canards et incrémente le numéro de l'image du vol:
    For i = 1 To 3
       
        Canard(i).X = Canard(i).X + 10
    
        ' Incrément l'indice dans la liste des images. Si fin du cycle alors reprend au début.
        Canard(i).IndiceImage = Canard(i).IndiceImage + 1
        If Canard(i).IndiceImage > UBound(ListeImages) Then Canard(i).IndiceImage = 0
    
        ' NumImage contient le numéro de l'image du vol à utiliser:
        NumImage = ListeImages(Canard(i).IndiceImage)
        
        ' Copie le canard en mémoire de travail -1 en X, Y, avec couleur de transparence 0:
        Call GdiTransparentBlt(Image(-1).Hdc, Canard(i).X, Canard(i).Y, 75, 84, _
                               Image(NumImage).Hdc, 0, 0, 75, 84, 0)
    Next i
     
    ' Affiche à l'écran la mémoire de travail -1:
    Call BitBlt(Hdc, 0, 0, GetSystemMetrics(0), GetSystemMetrics(1), Image(-1).Hdc, 0, 0, SRCCOPY)
    
    ' Fait une pause:
    Call Sleep(40)
    
Loop While Canard(1).X < GetSystemMetrics(0) Or Canard(2).X < GetSystemMetrics(0) _
                                             Or Canard(3).X < GetSystemMetrics(0)
' Libère les mémoires:
For i = -1 To 8
    DeleteObject SelectObject(Image(i).Hdc, Image(i).Obj)
    DeleteDC Image(i).Hdc
Next i
ReleaseDC 0, Hdc

End Sub

Certains développeurs utilisent les termes de héros, de lutin (Sprite en anglais) ou d'avatar pour désigner ces « personnages » animés qui sont présents dans leurs jeux. J'ai une préférence pour « Avatar ».

Nous avons déjà pratiquement fait le tour des API de base nous permettant de programmer en mode graphique. Avouez que finalement ce n'est pas bien compliqué, surtout quand c'est bien expliqué.

Il nous reste juste à étudier les API qui permettent d'interagir avec l'utilisateur, ou le joueur, en lisant les périphériques d'entrée (souris et clavier) mais aussi en ajoutant des effets sonores.

IX. Les API pour gérer la souris, le clavier, et le son

Vos applications en mode graphique nécessiteront sûrement d'utiliser les API suivantes pour gérer la souris, le clavier, et apporter du son.

API pour modifier la forme de la souris en chargeant un curseur d'après un fichier « .cur » :

 
Sélectionnez
Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal Id As Long) As Long 
Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long

Exemples :

Call SetSystemCursor(LoadCursorFromFile("C:\WINDOWS\Cursors\aero_unavail.cur"), 32512) Image non disponible

Call SetSystemCursor(LoadCursorFromFile("C:\WINDOWS\Cursors\aero_arrow.cur"), 32512) Image non disponible

API pour masquer ou afficher la souris :

 
Sélectionnez
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Exemples :

 
Sélectionnez
Call ShowCursor(0)  ' Masque le curseur de la souris
Call ShowCursor(1)  ' Affiche le curseur de la souris

API pour mémoriser et déterminer l'espace de déplacement de la souris :

 
Sélectionnez
Declare Function GetClipCursor Lib "user32" (lprc As RECT) As Long 
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long

Exemples :

 
Sélectionnez
Dim SourisEspace As RECT
Dim SourisBloque As RECT
Call GetClipCursor(SourisEspace)  ' Alimente SourisEspace des coordonnées de l'espace de déplacement.
SourisBloque.Top = 50             ' Limite haute de la souris
SourisBloque.Left = 50            ' Limite gauche de la souris
SourisBloque.Right = 100          ' Limite droite de la souris
SourisBloque.Bottom = 100         ' Limite basse de la souris.
Call ClipCursor(SourisBloque)     ' Bloque la souris dans l'espace 50, 50 à 100, 100
Call ClipCursor(SourisEspace)     ' Restaure l'espace de déplacement d'origine.

API pour connaître la position de la souris :

 
Sélectionnez
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long

Exemple :

 
Sélectionnez
Dim PositionSouris as POINT
Call GetCursorPos(PositionSouris) ' Alimente PositionSouris.X et PositionSouris.Y

API pour savoir si une touche du clavier est enfoncée :

 
Sélectionnez
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

Exemple :

 
Sélectionnez
Do
    DoEvents
    If GetKeyState(vbKeyDelete) < 0 Then Exit Do ' Sort si la touche Suppr est enfoncée.
Loop

Retrouvez la liste des codes nVirtKey des touches dans l'aide d'Excel à la rubrique : « Constantes de code de touches ». vbKeyLButton (1) et vbKeyRButton (2) représentent les boutons gauche et droit de la souris.

API pour jouer le son d'un fichier WAV :

 
Sélectionnez
Declare Function PlaySound Lib "Winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long 
Public Const pcsSYNC = 0      ' Suspend l'exécution du code tant que le son n'est pas fini.
Public Const pcsASYNC = 1     ' Joue le son tout en continuant l'exécution du code.
Public Const pcsLOOP = 8      ' Joue le son en boucle, tant qu'un nouveau son n'est pas à jouer.
Public Const pcsNOSTOP = 16   ' N'interrompe pas le son en cours.

Exemples :

Joue le fichier laser-01.wav, une seule fois, sans interrompre le traitement :

 
Sélectionnez
Call PlaySound(ThisWorkbook.Path & "\laser-01.wav", pcsASYNC)

Joue le fichier laser-01.wav, en boucle, sans interrompre le traitement, tant qu'un autre appel à la fonction n'est pas réalisé :

 
Sélectionnez
Call PlaySound(ThisWorkbook.Path & "\laser-01.wav", pcsLOOP + pcsASYNC)

Force la fin d'un son joué en boucle :

 
Sélectionnez
Call PlaySound(" ", pcsASYNC)

Et pour faire parler votre ordinateur, en anglais :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub Speak(StrTexte As String)
'---------------------------------------------------------------------------------------
Static Voice As Object
If Voice Is Nothing Then Set Voice = CreateObject("SAPI.Spvoice")
Voice.Speak StrTexte
If StrTexte = "" Then Set Voice = Nothing
End Sub

Notre prochaine étape sera de développer des procédures pour utiliser plus simplement toutes les API que nous venons d'étudier.

Ces procédures seront regroupées dans le module Img. Les API et les déclarations publiques utilisées seront regroupées dans un module ordinaire Img_Déclarations.

X. Procédures du module Img pour écrire du texte

Dans un nouveau module que nous appellerons Img, nous allons développer des procédures pour simplifier l'usage des API dédiées à la programmation en mode graphique que nous venons d'étudier.
En commençant par le plus compliqué, écrire du texte.

Nous avons vu deux possibilités : écrire sur un fond opaque, ou écrire en transparence. Avec un point commun, car dans les deux cas il est nécessaire de définir en amont, la couleur du texte, la couleur du fond, et les 14 paramètres du modèle d'écriture, ce qui représente des manipulations fastidieuses.
Deux procédures vont nous simplifier la tâche : TexteConfig pour configurer le modèle d'écriture à utiliser, et Texte qui permet d'écrire soit sur un fond opaque soit en transparence.

La procédure TexteConfig configure un modèle d'écriture en passant en arguments : le numéro du modèle à créer, la couleur du texte, la couleur du fond (-1 pour une transparence), le nom de la police, sa taille, et en option son épaisseur, le mode italique, le mode souligné.
La matrice Police mémorisera les différents modèles que nous créerons.
L'objet du modèle d'écriture créé, mémorisé dans la variable Obj de la matrice Police, sera appelé rapidement par SelectObject(Hdc, Police(NuméroDuModèle).Obj) dans la procédure Texte.

 
Sélectionnez
Public Type TypePolice
    Obj As Long
    Taille As Long
    Hauteur As Long
    CoulTexte As Long
    CoulFond As Long
End Type
Public Police(0 To 9) As TypePolice

'---------------------------------------------------------------------------------------
Public Sub TexteConfig(NumPolice As Byte, CouleurTexte As Long, CouleurFond As Long, _
           NomPolice As String, Taille As Byte, Optional Epaisseur As Integer = 500, _
           Optional Italique As Boolean = False, Optional Souligné As Boolean = False)
'---------------------------------------------------------------------------------------
' Mémorise la configuration pour le modèle de police:
Police(NumPolice).CoulTexte = CouleurTexte
Police(NumPolice).CoulFond = CouleurFond
Police(NumPolice).Obj = CreateFont(Taille, 0, 0, 0, Epaisseur, _
                                   -Italique, -Souligné, 0, 0, 0, 0, 0, 0, NomPolice)
Police(NumPolice).Taille = Taille
 
' Création d'une mémoire image de hauteur et largeur de la police:
Dim Tps_Img As Long, Tps_Hdc As Long, Tps_Obj As Long
Tps_Img = CreateCompatibleBitmap(Hdc, Police(NumPolice).Taille, Police(NumPolice).Taille)
Tps_Hdc = CreateCompatibleDC(Hdc)
Tps_Obj = SelectObject(Tps_Hdc, Tps_Img)
 
' Y copie un caractère avec fond plein:
Call SetTextColor(Tps_Hdc, 255)
Call SetBkColor(Tps_Hdc, 255)
Call SelectObject(Tps_Hdc, Police(NumPolice).Obj)
Call TextOut(Tps_Hdc, 0, 0, " ", 1)
 
' Recherche la hauteur réelle du texte, c.-à-d. tant qu'un pixel à 0 n'est pas rencontré:
For Police(NumPolice).Hauteur = Police(NumPolice).Taille To 1 Step -1
    If GetPixel(Tps_Hdc, 1, Police(NumPolice).Hauteur - 1) <> 0 Then Exit For
Next Police(NumPolice).Hauteur
 
' Libération des mémoires:
DeleteObject SelectObject(Tps_Hdc, Tps_Obj)
DeleteDC Tps_Hdc
End Sub

Remarques sur la procédure TexteConfig :

  • La procédure calcule la hauteur réelle d'un caractère dans la police choisie, de façon à optimiser l'affichage pour un texte écrit en transparence. Pour cela il faut faire un test en écrivant un caractère dans une mémoire temporaire et rechercher dans cette mémoire où est la dernière ligne de la couleur de fond. Ce résultat est mémorisé dans la variable Hauteur de la matrice Police.
  • Seuls les cinq principaux paramètres sont configurés par cette procédure : nom de la police, taille, épaisseur, italique, souligné. En cas de besoin, vous pouvez configurer les autres paramètres par un appel à l'API : Police(NumPolice).Obj = CreateFont(…)

La fonction Texte permet d'écrire soit sur un fond opaque soit en transparence. Elle retourne la largeur en pixels du texte, s'il est écrit en transparence.

Quatre arguments sont obligatoires : le contexte, l'abscisse, l'ordonnée, le texte à écrire.

Quatre arguments sont facultatifs : le numéro du modèle de police, créé par TexteConfig (par défaut c'est le modèle 0), l'alignement horizontal (à gauche par défaut, AlignH_Gauche), la couleur du texte, et la couleur du fond (s'il ne faut pas utiliser les couleurs du modèle).

Remarques sur la procédure Texte :

  • Dans un jeu où il est nécessaire de réduire les temps de traitement, écrire sur un fond opaque avec TextOut est plus rapide que d'écrire en transparence avec GdiTransparentBlt, comme nous l'avons déjà étudié.
  • Utilisez la couleur de fond -1 pour une transparence.
  • La couleur de transparence utilisée est la couleur du texte + 1, ceci afin de réduire les effets de contraste sur certaines couleurs que GdiTransparentBlt a du mal à gérer.

Exemple pour définir le modèle 0 afin d'écrire en noir sur fond transparent, avec la police Arial taille 40.

 
Sélectionnez
Call Img.TexteConfig(0, 0, -1, "Arial", 40)
Call Img.Texte(Hdc, 300, 440, "Démonstration :")

Et pour écrire avec ce modèle, mais en alignant le texte à droite, en blanc sur fond rouge :

 
Sélectionnez
Call Img.Texte(Hdc, 300, 440, "Démonstration :", 0, AlignH_Droite, 15, 12)

Exemple pour écrire avec ce modèle, centré sur l'écran et encadré d'un rectangle noir :

 
Sélectionnez
' Écrit le texte centré à l'écran, et récupère la taille en pixels du texte:
Lg = Img.Texte(Hdc, (ImageMaxiX / 2), (ImageMaxiY / 2) - (Police(0).Hauteur / 2), _
              "Démonstration :", 0, AlignH_Centre)

' Dessine un rectangle vide noir au centre de l'écran de la taille du texte:
Call Img.RectangleVide(Hdc, (ImageMaxiX / 2) - (Lg / 2), _
                            (ImageMaxiY / 2) - (Police(0).Hauteur / 2), _
                            (ImageMaxiX / 2) + (Lg / 2), _
                            (ImageMaxiY / 2) + (Police(0).Hauteur / 2))
 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Function Texte(HdcDest As Long, ByVal Px As Long, Py As Long, StrTexte As Variant, _
Optional NumPolice As Byte = 0, Optional AlignementHorizontal As EnumAlignH = 0, _
Optional ByVal CouleurTexte As Long = -9, Optional ByVal CouleurFond As Long = -9) As Long
'---------------------------------------------------------------------------------------
' Prend la couleur de texte du modèle sauf si une couleur de texte est passée en argument:
If CouleurTexte = -9 Then CouleurTexte = Police(NumPolice).CoulTexte
If CouleurTexte > 0 And CouleurTexte < 12 Then CouleurTexte = QBColor(CouleurTexte)
If CouleurTexte >= 12 And CouleurTexte < 16 Then CouleurTexte = QBColor(CouleurTexte) - 1
If CouleurTexte = 0 Then CouleurTexte = 1
If CouleurTexte > 16777214 Then CouleurTexte = 16777214

' Prend la couleur de fond du modèle sauf si une couleur de fond est passée en argument:
If CouleurFond = -9 Then CouleurFond = Police(NumPolice).CoulFond
If CouleurFond > 0 And CouleurFond < 16 Then CouleurFond = QBColor(CouleurFond)
If CouleurFond = 0 Then CouleurFond = 1
 
' Si pas de transparence et alignement à Gauche alors utilise le mode rapide:
If CouleurFond <> -1 And AlignementHorizontal = AlignH_Gauche Then
    Call SetTextColor(HdcDest, CouleurTexte)
    Call SetBkColor(HdcDest, CouleurFond)
    Call SelectObject(HdcDest, Police(NumPolice).Obj)
    Call TextOut(HdcDest, Px, Py, StrTexte, Len(StrTexte))
    Exit Function
End If
 
' Détermine la largeur du texte:
Dim Largeur As Long
Largeur = Len(StrTexte) * Police(NumPolice).Taille
 
' Création d'une mémoire vierge (initialisée à 0) qui contiendra le texte:
Dim Tps_Img As Long, Tps_Hdc As Long, Tps_Obj As Long
Tps_Img = CreateCompatibleBitmap(Hdc, Largeur, Police(NumPolice).Hauteur)
Tps_Hdc = CreateCompatibleDC(Hdc)
Tps_Obj = SelectObject(Tps_Hdc, Tps_Img)
 
' Affectation de la couleur de texte, couleur de fond (ou de transparence) et de la police:
Call SetTextColor(Tps_Hdc, CouleurTexte)
Call SetBkColor(Tps_Hdc, IIf(CouleurFond = -1, CouleurTexte + 1, CouleurFond))
Call SelectObject(Tps_Hdc, Police(NumPolice).Obj)
 
' Génère le texte dans l'espace mémoire Tps_Hdc. Les pixels non utilisés restent à 0:
Call TextOut(Tps_Hdc, 0, 0, StrTexte, Len(StrTexte))
 
' Recherche la largeur réelle du texte, c.-à-d., tant qu'un pixel à 0 n'est pas rencontré:
Dim MaxiLg As Long
For MaxiLg = Largeur - 1 To 0 Step -1
    If GetPixel(Tps_Hdc, MaxiLg, 1) <> 0 Then Exit For
Next MaxiLg
Texte = MaxiLg ' Retourne le nombre de pixels pour afficher le texte.

' Si alignement à Droite ou Centre alors modifie la position Px:
If AlignementHorizontal = AlignH_Droite Then Px = Px - MaxiLg
If AlignementHorizontal = AlignH_Centre Then Px = Px - (MaxiLg / 2)
 
' Affiche le texte en transparence ou en utilisant une couleur de fond:
If CouleurFond = -1 Then
    Call GdiTransparentBlt(HdcDest, Px, Py, MaxiLg, Police(NumPolice).Hauteur, _
                          Tps_Hdc, 0, 0, MaxiLg, Police(NumPolice).Hauteur, CouleurTexte + 1)
Else
    Call BitBlt(HdcDest, Px, Py, MaxiLg, Police(NumPolice).Hauteur, Tps_Hdc, 0, 0, SRCCOPY)
End If
 
' Libération des mémoires:
DeleteObject SelectObject(Tps_Hdc, Tps_Obj)
DeleteDC Tps_Hdc

End Function

XI. Procédures du module Img pour dessiner des formes géométriques

Pour dessiner les formes géométriques de bases, trait, rectangle, et autres polygones pleins ou vides, nous allons utiliser une procédure qui sait tout faire, car elle regroupe les API Polygon (pour les formes pleines) et LineTo (pour les formes vides, c'est-à-dire lorsque le fond est déclaré transparent).

C'est la procédure Polygone.

Deux arguments sont obligatoires : le contexte, et la liste des points (abscisse, ordonnée) passée sous forme d'un tableau Array().

Cinq arguments sont facultatifs : la couleur du trait, la couleur de fond, la taille du trait, le style du trait pour CreatePen (qui n'est appliqué que si la taille vaut 1), et le style du fond pour CreateHatchBrush (qui est 7, FondTransparent, pour un fond transparent).

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub Polygone(HdcDest As Long, ListePointsXY As Variant, _
       Optional ByVal CouleurTrait As Long = 0, Optional ByVal CouleurFond As Long = 0, _
       Optional Taille As Long = 1, Optional StyleTrait As EnumPenStyle = PenSolide, _
       Optional StyleFond As EnumBrushStyle = FondPlein)
'---------------------------------------------------------------------------------------
Dim Cpt As Long
Dim PolyPoints() As POINT, Pt As POINT
 
' Redimensionne le tableau de points pour l'API:
ReDim PolyPoints(((UBound(ListePointsXY) + 1) / 2) - 1)
 
' Boucle sur les coordonnées du tableau passé en paramètre pour charger les éléments:
For Cpt = 0 To (UBound(ListePointsXY) - 1) / 2
    PolyPoints(Cpt).X = ListePointsXY(2 * Cpt) ' Abcisse du point
    PolyPoints(Cpt).Y = ListePointsXY(2 * Cpt + 1) ' Ordonnée du point
Next
 
' Transforme la couleur du trait Basic (0 à 15) en couleur RVB:
If CouleurTrait > 0 And CouleurTrait < 16 Then CouleurTrait = QBColor(CouleurTrait)
 
' Crée et sélectionne les options du trait:
Dim ObjPen As Long
ObjPen = CreatePen(StyleTrait, Taille, CouleurTrait)
Call SelectObject(HdcDest, ObjPen)
 
' Transforme la couleur du fond Basic (0 à 15) en couleur RVB:
If CouleurFond > 0 And CouleurFond < 16 Then CouleurFond = QBColor(CouleurFond)
 
' Crée et sélectionne les options du fond:
Dim ObjBrush As Long
ObjBrush = CreateHatchBrush(StyleFond, CouleurFond)
Call SelectObject(HdcDest, ObjBrush)
   
' Dessine le polygone en plein si StyleFond <> FondTransparent sinon en vide:
If StyleFond <> FondTransparent Then
    Call Polygon(HdcDest, PolyPoints(0), UBound(PolyPoints) + 1)
Else
    Call MoveToEx(HdcDest, PolyPoints(0).X, PolyPoints(0).Y, Pt)
    For Cpt = 1 To UBound(PolyPoints)
        Call LineTo(HdcDest, PolyPoints(Cpt).X, PolyPoints(Cpt).Y)
    Next Cpt
End If
 
' Libération des mémoires:
DeleteObject ObjPen
DeleteObject ObjBrush
End Sub

La procédure peut être appelée pour dessiner un rectangle vide, en pointillés :

 
Sélectionnez
Call Img.Polygone(Hdc, Array(100, 100, 400, 100, 400, 200, 100, 200, 100, 100), _
                  0, 0, 1, PenPoint, FondTransparent)

Mais j'ai préféré développer une procédure spécifique RectangleVide, qui fait appel à Polygone, où l'on ne passe en argument que le contexte, les coordonnées des points opposés du rectangle X1, Y1 et X2, Y2, en option la couleur du trait (0 par défaut), la taille (1 par défaut), et enfin le style du trait (0 par défaut) :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub RectangleVide(HdcDest As Long, X1 As Long, Y1 As Long, _
           X2 As Long, Y2 As Long, Optional CouleurTrait As Long = 0, _
           Optional Taille As Long = 1, Optional StyleTrait As EnumPenStyle = PenSolide)
'---------------------------------------------------------------------------------------
Call Polygone(HdcDest, Array(X1, Y1, X2, Y1, X2, Y2, X1, Y2, X1, Y1), _
              CouleurTrait, 0, Taille, StyleTrait, FondTransparent)
End Sub

Pour obtenir le même résultat que précédemment, l'appel est simplifié en :

 
Sélectionnez
Call Img.RectangleVide(Hdc, 100, 100, 400, 200, 0, 1, PenPoint)

De même une procédure spécifique permet de dessiner un rectangle plein :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub RectanglePlein(HdcDest As Long, X1 As Long, Y1 As Long, _
           X2 As Long, Y2 As Long, Optional CouleurFond As Long = 0, _
           Optional StyleFond As EnumBrushStyle = FondPlein)
'---------------------------------------------------------------------------------------
Call Polygone(HdcDest, Array(X1, Y1, X2, Y1, X2, Y2, X1, Y2, X1, Y1), _
              CouleurFond, CouleurFond, 1, PenSolide, StyleFond)
End Sub

L'appel est simplifié avec en arguments : le contexte, les coordonnées des points opposés du rectangle X1, Y1 et X2, Y2, en option la couleur du trait (0 par défaut), et le style du trait (0 par défaut) :

 
Sélectionnez
Call Img.RectanglePlein(Hdc, 100, 100, 400, 200)

Un trait peut être représenté par un polygone vide ayant deux points. Les arguments nécessaires sont : le contexte, les coordonnées des deux points X1, Y1 et X2, Y2, en option la couleur du trait (0 par défaut), la taille du trait (1 par défaut), et le style du trait (0 par défaut) :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub Trait(HdcDest As Long, X1 As Long, Y1 As Long, _
           X2 As Long, Y2 As Long, Optional CouleurTrait As Long = 0, _
           Optional Taille As Long = 1, Optional StyleTrait As EnumPenStyle = PenSolide)
'---------------------------------------------------------------------------------------
Call Polygone(HdcDest, Array(X1, Y1, X2, Y2), _
              CouleurTrait, CouleurTrait, Taille, StyleTrait, FondPlein)
End Sub

Ce qui permet de dessiner un trait rouge en pointillé par cet appel :

 
Sélectionnez
Call Img.Trait(Hdc, 100, 100, 400, 100, 12, , PenPoint)

La dernière procédure de ce chapitre est utilisée pour dessiner un cercle, vide ou plein.

Les arguments de la procédure Cercle sont : le contexte, l'abscisse et l'ordonnée du centre du cercle, le diamètre du cercle, la couleur du cercle, et en option s'il est plein ou vide (vide par défaut) :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub Cercle(HdcDest As Long, Px As Long, Py As Long, _
           Taille As Long, ByVal Couleur As Long, Optional Plein As Boolean = False)
'---------------------------------------------------------------------------------------
 
' Transforme la couleur du cercle Basic (0 à 15) en couleur RVB:
If Couleur < 16 Then Couleur = QBColor(Couleur)
If Couleur = 0 Then Couleur = 1 ' La couleur 0 est réservée pour la transparence.
 
' Création d'une mémoire travail de la taille du cercle, initialisée avec des pixels à 0:
Dim Tps_Img As Long, Tps_Hdc As Long, Tps_Obj As Long
Tps_Img = CreateCompatibleBitmap(Hdc, Taille * 2, Taille * 2)
Tps_Hdc = CreateCompatibleDC(Hdc)
Tps_Obj = SelectObject(Tps_Hdc, Tps_Img)
 
' Sélectionne un trait fin de la couleur demandée:
Dim ObjPen As Long
ObjPen = CreatePen(0, 1, Couleur)
Call SelectObject(Tps_Hdc, ObjPen)
 
' Sélectionne la couleur du fond demandée ou 0 si cercle vide:
Dim ObjBrush As Long
ObjBrush = CreateSolidBrush(IIf(Plein = False, 0, Couleur))
Call SelectObject(Tps_Hdc, ObjBrush)
 
' Dessine le cercle en mémoire de travail:
Call Ellipse(Tps_Hdc, 0, 0, Taille * 2, Taille * 2)
 
' Copie le cercle calculé en mémoire sans les pixels à 0:
Call GdiTransparentBlt(HdcDest, Px - Taille, Py - Taille, Taille * 2, Taille * 2, _
                       Tps_Hdc, 0, 0, Taille * 2, Taille * 2, 0)
 
' Libération des mémoires:
DeleteObject ObjPen
DeleteObject ObjBrush
DeleteObject SelectObject(Tps_Hdc, Tps_Obj)
DeleteDC Tps_Hdc
End Sub

Exemple d'appel pour dessiner un cercle bleu plein, de 130 pixels de diamètre, dont le centre est aux coordonnées 500, 500 :

 
Sélectionnez
Call Img.Cercle(Hdc, 500, 500, 130, 1, True)

XII. Procédures du module Img pour gérer les images

La gestion des images sera simplifiée par l'utilisation de variables publiques et de types personnalisés.

Variables publiques :

 
Sélectionnez
Public Hdc As Long
Public ImageMiniX As Long, ImageMiniY As Long
Public ImageMaxiX As Long, ImageMaxiY As Long
Public ImageNum As Integer
Public Pt As POINT
Public Type POINT
     x As Long: Y As Long
End Type
Public Enum EnumAlignH
    AlignH_Gauche = 0
    AlignH_Centre = 1
    AlignH_Droite = 2
End Enum
Public Enum EnumAlignV
    AlignV_Haut = 0
    AlignV_Centre = 1
    AlignV_Bas = 2
End Enum
Public Enum EnumTypeAnimation
    EnBoucle = 0
    UneFoisEtAffiche = 1
    UneFoisEtQuitte = 2
End Enum

Type personnalisé pour l'affichage des images :

 
Sélectionnez
Public Type TypeImage
    Img As Variant
    Hdc As Long
    Obj As Long
    Largeur As Long
    Hauteur As Long
    Transparence As Long
    AlignH As EnumAlignH
    AlignV As EnumAlignV
End Type
Public Image(-1 To 999) As TypeImage

Type personnalisé pour l'animation des avatars :

 
Sélectionnez
Public Type TypeAvatar
    X As Long
    Y As Long
    MvX As Integer
    MvY As Integer
    Actif As Boolean
    Visible As Boolean
    SpriteActif As Integer
    ListeImages As Variant
    SpriteBloqué As Integer
    Animation As EnumTypeAnimation
    PosXMini As Long: PosXMaxi As Long
    PosYMini As Long: PosYMaxi As Long
End Type
Public Avatar(0 To 99) As TypeAvatar

Et grâce aux procédures qui suivent.

La première chose à faire dans un programme en mode graphique est de récupérer le contexte de l'écran et de mémoriser ses dimensions. On peut alors créer une image de la taille de l'écran pour le mémoriser (image numéro 0), et en faire une copie pour une mémoire de travail (image numéro -1).
Ces actions sont effectuées par la procédure InitialiseModeGraphique :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub InitialiseModeGraphique()
'---------------------------------------------------------------------------------------
' Mémorise le contexte de l'écran:
Hdc = GetWindowDC(0)

' Mémorise la taille de l'écran:
ImageMaxiX = GetSystemMetrics(0): ImageMiniX = 0
ImageMaxiY = GetSystemMetrics(1): ImageMiniY = 0

' Création de l'image 0 pour mémoriser l'écran d'origine
Image(0).Img = CreateCompatibleBitmap(Hdc, ImageMaxiX, ImageMaxiY)
Image(ImgDest).Hdc = CreateCompatibleDC(Hdc)
Image(ImgDest).Obj = SelectObject(Image(0).Hdc, Image(0).Img)
Image(ImgDest).Largeur = ImageMaxiX
Image(ImgDest).Hauteur = ImageMaxiY
Image(ImgDest).Transparence = -1 ' Sans transparence

' Mémorise l'écran en mémoire 0 puis fait une copie en mémoire -1.
Call BilBlt(Image(0).Hdc, 0, 0, ImageMaxiX, ImageMaxiY, Hdc, 0, 0, SRCCOPY)
Call CopieImage(0, -1)

End Sub

Inversement, la procédure FermeModeGraphique permet de libérer les mémoires utilisées par la gestion des images avant de quitter le mode graphique :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub FermeModeGraphique()
'---------------------------------------------------------------------------------------
' Libère les mémoires:
For ImageNum = -1 To Ubound(Image())
    DeleteObject SelectObject(Image(ImageNum).Hdc, Image(ImageNum).Obj)
    DeleteDC Image(ImageNum).Hdc
Next ImageNum

ReleaseDC 0, Hdc
End Sub

La procédure EffaceImage permet de libérer la mémoire passée en argument. Mémoire image qui pourra ensuite être réutilisée. Cela est utile pour l'usage des mémoires temporaires.

Par convention, les images 1 à 9 seront réservées par les procédures du module Img pour servir de mémoires temporaires, en plus des mémoires -1 et 0. Utilisez les mémoires 10 à 999 pour vos applications.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub EffaceImage(NumImage)
'---------------------------------------------------------------------------------------
DeleteObject SelectObject(Image(NumImage).Hdc, Image(NumImage).Obj)
DeleteDC Image(NumImage).Hdc
Image(NumImage).Hdc = 0
End Sub

La procédure CopieImage copie une image source dans une image destination (généralement l'image de travail -1), en utilisant ou non une couleur de transparence, tout dépend de la configuration de l'image source : si Transparence est différent de -1 alors l'image est copiée par l'API GdiTransparentBlt avec la couleur de transparence indiquée, sinon elle est copiée avec l'API BitBlt, donc sans transparence.
Par défaut, c'est l'intégralité de l'image source qui est copiée au point 0, 0 de l'image destination, mais six arguments facultatifs permettent de modifier l'emplacement de la destination (XDest et YDest) ou de définir la fraction de l'image source à copier (XSource, YSource, Largeur, Hauteur).

Notez que si l'image destination n'existe pas encore, alors elle est créée. Dans ce cas la couleur de transparence de l'image source est reprise pour configurer l'image créée. Idem pour son alignement.

Par exemple, la procédure InitialiseModeGraphique fait une copie de l'image écran (mémoire image 0) en image de travail (mémoire image -1) par l'instruction :

 
Sélectionnez
Call Img.CopieImage(0, -1)

Il existe une autre façon de créer une mémoire avec cette fonction : en utilisant le même numéro d'image pour la source et la destination. Dans ce cas l'image destination est créée avec la largeur et la hauteur passée en argument.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub CopieImage(ImgSource As Integer, ImgDest As Integer, _
                      Optional ByVal XDest As Long = 0, Optional ByVal YDest As Long = 0, _
                      Optional XSource As Long = 0, Optional YSource As Long = 0, _
                      Optional Largeur As Long = 0, Optional Hauteur As Long = 0)
'---------------------------------------------------------------------------------------
' Définit la largeur et la hauteur de l'image ou prend les valeurs de la source:
Dim Lg As Long, Ht As Long
Lg = IIf(Largeur = 0, Image(ImgSource).Largeur, Largeur)
Ht = IIf(Hauteur = 0, Image(ImgSource).Hauteur, Hauteur)
 
' Si la destination n'existe pas alors il faut la créer:
If Image(ImgDest).Hdc = 0 Then
    Image(ImgDest).Img = CreateCompatibleBitmap(Hdc, Lg, Ht)
    Image(ImgDest).Hdc = CreateCompatibleDC(Hdc)
    Image(ImgDest).Obj = SelectObject(Image(ImgDest).Hdc, Image(ImgDest).Img)
    Image(ImgDest).Largeur = Lg
    Image(ImgDest).Hauteur = Ht
    Image(ImgDest).Transparence = Image(ImgSource).Transparence
    Image(ImgDest).AlignH = Image(ImgSource).AlignH
    Image(ImgDest).AlignV = Image(ImgSource).AlignV
    If ImgSource = ImgDest Then Exit Sub
End If
 
' S'il faut appliquer un alignement horizontal ou vertical:
If Image(ImgSource).AlignH = AlignH_Centre Then XDest = XDest - (Lg / 2)
If Image(ImgSource).AlignH = AlignH_Droite Then XDest = XDest - Lg
If Image(ImgSource).AlignV = AlignV_Centre Then YDest = YDest - (Ht / 2)
If Image(ImgSource).AlignV = AlignV_Bas Then YDest = YDest - Ht
 
' Copie l'image en transparence ou sans transparence:
If Image(ImgSource).Transparence <> -1 Then
    Call GdiTransparentBlt(Image(ImgDest).Hdc, XDest, YDest, _
                           Lg, Ht, Image(ImgSource).Hdc, XSource, YSource, _
                           Lg, Ht, Image(ImgSource).Transparence)
Else
    Call BitBlt(Image(ImgDest).Hdc, XDest, YDest, Lg, Ht, _
                Image(ImgSource).Hdc, XSource, YSource, SRCCOPY)
End If
 
End Sub

La procédure CopieEcran sera parfois nécessaire pour faire une nouvelle mémorisation de l'écran avant d'y faire vos animations. L'image numéro 0 est utilisée comme modèle afin de créer une nouvelle image de la dimension de l'écran.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub CopieEcran(NumImage As Integer)
'---------------------------------------------------------------------------------------
Call EffaceImage(NumImage)
Call CopieImage(0, NumImage)
Call BitBlt(Image(NumImage).Hdc, 0, 0, ImageMaxiX, ImageMaxiY, Hdc, 0, 0, SRCCOPY)

End Sub

La procédure ModifieTailleImage modifie la taille d'une image ImgSource (Lg est la nouvelle largeur, Ht la nouvelle hauteur) avec l'API StretchBlt. Si le numéro de l'image destination imgDest est différent de l'image source, alors une nouvelle image est créée, en récupérant la configuration de l'image source.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub ModifieTailleImage(ImgSource As Integer, Lg As Long, Ht As Long, _
                              Optional ByVal ImgDest As Integer = -9)
'---------------------------------------------------------------------------------------
Call EffaceImage(1) ' Création d'une mémoire 1 de la nouvelle taille.
Call CopieImage(1, 1, , , , , Lg, Ht)
 
' Modifie la taille de l'image en mémoire 1:
Call StretchBlt(Image(1).Hdc, 0, 0, Lg, Ht, Image(ImgSource).Hdc, _
                0, 0, Image(ImgSource).Largeur, Image(ImgSource).Hauteur, SRCCOPY)
 
' Soit il faut garder cette image:
If ImgDest = -9 Or ImgDest = ImgSource Then
    Call EffaceImage(ImgSource) ' Création d'une mémoire de la nouvelle taille.
    Call CopieImage(ImgSource, ImgSource, , , , , Lg, Ht)
    Call BitBlt(Image(ImgSource).Hdc, 0, 0, Lg, Ht, Image(1).Hdc, 0, 0, SRCCOPY)
Else ' Soit il faut générer une autre image:
    Call EffaceImage(ImgDest)   ' Efface l'image destination
    Call CopieImage(1, ImgDest) ' Création d'une image de la nouvelle taille.
    Call BitBlt(Image(ImgDest).Hdc, 0, 0, Lg, Ht, Image(1).Hdc, 0, 0, SRCCOPY) ' Copie l'image 1.
    Image(ImgDest).Transparence = Image(ImgSource).Transparence ' Reprise de la transparence.
    Image(ImgDest).AlignH = Image(ImgSource).AlignH             ' Reprise de l'alignement Horizontal.
    Image(ImgDest).AlignV = Image(ImgSource).AlignV             ' Reprise de l'alignement vertical.
End If
Call EffaceImage(1)
End Sub

Vous aurez aussi besoin dans vos applications de retourner une image. Un canard pourra ainsi voler aussi bien de gauche à droite que de droite à gauche.

La procédure TourneImage ne nécessite que deux arguments, le numéro de l'image source, ImgSource, et le numéro de la nouvelle image à créer, ImgDest.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub TourneImage(ImgSource As Integer, ImgDest As Integer)
'---------------------------------------------------------------------------------------
' Création de la nouvelle image d'après le modèle de l'image d'origine:
Call CopieImage(ImgSource, ImgDest)
    
' Retourne l'image d'origine:
Dim x As Long, Y As Long
For Y = 0 To Image(ImgSource).Hauteur - 1
    For x = 0 To Image(ImgSource).Largeur - 1
        Call SetPixel(Image(ImgDest).Hdc, Image(ImgDest).Largeur - 1 - x, Y, _
                      GetPixel(Image(ImgSource).Hdc, x, Y))
    Next x
Next Y

End Sub

La procédure AfficheImage affiche à l'écran l'intégralité d'une image (généralement l'image de travail numéro -1), là aussi en utilisant ou non une couleur de transparence, tout dépend de la configuration de l'image passée en argument : si Transparence est différent de -1 alors l'image est affichée par l'API GdiTransparentBlt avec la couleur de transparence indiquée, sinon elle est affichée avec l'API BitBlt, donc sans transparence.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub AfficheImage(ImgSource As Integer)
'---------------------------------------------------------------------------------------
If Image(ImgSource).Transparence <> -1 Then
    Call GdiTransparentBlt(Hdc, 0, 0, _
                           Image(ImgSource).Largeur, Image(ImgSource).Hauteur, _
                           Image(ImgSource).Hdc, 0, 0, _
                           Image(ImgSource).Largeur, Image(ImgSource).Hauteur, _
                           Image(ImgSource).Transparence)
Else
    Call BitBlt(Hdc, 0, 0, Image(ImgSource).Largeur, Image(ImgSource).Hauteur, _
                Image(ImgSource).Hdc, 0, 0, SRCCOPY)
End If
 
End Sub

Nous avons déjà étudié comment charger en mémoire une image au format BMP. Rien de particulier donc pour la procédure ChargeImageBMP qui reprend les API LoadPicture pour créer l'image et GetObjectAPI pour connaître ses dimensions et ainsi les mémoriser dans le type personnalisé Image.
Le nom du fichier avec son chemin est le premier argument de la procédure, suivi du numéro d'image à créer.

La couleur de transparence, si elle est connue, peut être passée en option, ou utilisez la valeur -9 pour que cette couleur soit détectée automatiquement d'après le point d'origine 0, 0 de l'image. N'oubliez pas que la valeur -1 indique qu'il ne doit pas être appliqué de transparence dans les procédures de copie et d'affichage de l'image.
L'alignement horizontal (AlignH) et vertical (AlignV) de l'image sont les deux derniers arguments facultatifs.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub ChargeImageBMP(StrFichier As String, NumImage As Integer, _
                     Optional Transparence As Long = -9, _
                     Optional AlignH As EnumAlignH = 0, Optional AlignV As EnumAlignV = 0)
'---------------------------------------------------------------------------------------
Dim Tps_Bitmap As Bitmap
Set Image(NumImage).Img = LoadPicture(StrFichier)
Image(NumImage).Hdc = CreateCompatibleDC(Hdc)
Image(NumImage).Obj = SelectObject(Image(NumImage).Hdc, Image(NumImage).Img)
GetObjectAPI Image(NumImage).Img.handle, Len(Tps_Bitmap), Tps_Bitmap
 
' Mémorise la taille de l'image et son alignement:
Image(NumImage).Largeur = Tps_Bitmap.bmWidth
Image(NumImage).Hauteur = Tps_Bitmap.bmHeight
Image(NumImage).Transparence = Transparence
Image(NumImage).AlignH = AlignH
Image(NumImage).AlignV = AlignV
 
' Force à détecter la transparence d'après le point d'origine 0,0:
If Transparence = -9 Then Image(NumImage).Transparence = GetPixel(Image(NumImage).Hdc, 0, 0)
 
End Sub

Il nous reste une dernière procédure à étudier, AnimeAvatar, utilisée pour simplifier la gestion des avatars. Cette fonction gère le déplacement de l'avatar passé en argument en veillant à ne pas déborder des limites définies, et éventuellement, boucle sur la liste des images qui composent le Sprite pour générer une animation.

Revenons sur le type personnalisé Avatar, car la configuration de ses paramètres est très importante dans la gestion des avatars :

  • X et Y : définissent les coordonnées de l'avatar. C'est-à-dire où sera copiée l'image de l'avatar dans la mémoire ImgDest passée en argument, en utilisant l'alignement horizontal et vertical défini dans les paramètres de l'image (voir le type personnalisé Image).
  • MvX et MvY : définissent la vitesse de déplacement (nombre de pixels) de l'abscisse et de l'ordonnée de l'avatar. Ces valeurs vont alimenter les variables X et Y pour définir les nouvelles coordonnées de l'avatar après son déplacement. Si ces valeurs sont nulles, l'avatar restera donc immobile.
  • Actif : indique si l'avatar est actif (True). S'il ne l'est pas (False) la fonction AnimeAvatar ne fera rien.
    Attention, par défaut ce paramètre est à False.
  • Visible : indique si l'avatar sera affiché après son animation (True) ou non (False). Attention, par défaut ce paramètre est à False.
  • SpriteActif : est le numéro de l'élément dans la liste des images du Sprite et non pas le numéro de l'image. La fonction AnimeAvatar retourne le numéro de l'image utilisée.
  • ListeImages : contient la liste des numéros d'images qui composent le Sprite.
  • SpriteBloqué : si différent de zéro, est le numéro de l'image qu'il faut utiliser quand l'avatar atteint les limites de déplacement autorisées.
  • Animation : est le mode d'animation qui peut prendre les valeurs 0 (EnBoucle), pour une lecture en boucle des images du Sprite ; 1 (UneFoisEtAffiche) pour ne pas faire de boucle, la dernière image du Sprite est continuellement affichée ; 2 (UneFoisEtQuitte) pour ne pas faire de boucle, la dernière image du Sprite est affichée une seule fois puis la variable Actif est forcée à False. L'avatar n'est donc plus géré ; si une valeur supérieure à 2 est renseignée, l'animation est gérée en boucle et la variable Animation est décrémentée à chaque passage, jusqu'à atteindre la valeur 2 (UneFoisEtQuitte) ce qui met fin à l'animation. Technique à utiliser pour afficher un avatar un nombre de fois déterminé.
  • PosXMini, PosXMaxi, PosYMini, PosYMaxi : si ces valeurs sont différentes de zéro, elles définissent les limites de déplacement autorisées.

Vous comprendrez mieux avec le code de la procédure…

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Function AnimeAvatar(NumAvatar As Integer, Optional ImgDest As Integer = -1) As Integer
'---------------------------------------------------------------------------------------
' Si l'avatar n'est pas déclaré actif alors sort:
If Avatar(NumAvatar).Actif = False Then Exit Function

' Déplace l'avatar:
Avatar(NumAvatar).x = Avatar(NumAvatar).x + Avatar(NumAvatar).MvX
Avatar(NumAvatar).Y = Avatar(NumAvatar).Y + Avatar(NumAvatar).MvY

' Gère les débordements si PosXMini, PosXMaxi, PosYMini, PosXMaxi différents de 0:
If Avatar(NumAvatar).PosXMini <> 0 And Avatar(NumAvatar).x < Avatar(NumAvatar).PosXMini Then _
    Avatar(NumAvatar).x = Avatar(NumAvatar).PosXMini
If Avatar(NumAvatar).PosXMaxi <> 0 And Avatar(NumAvatar).x > Avatar(NumAvatar).PosXMaxi Then _
    Avatar(NumAvatar).x = Avatar(NumAvatar).PosXMaxi
If Avatar(NumAvatar).PosYMini <> 0 And Avatar(NumAvatar).Y < Avatar(NumAvatar).PosYMini Then _
    Avatar(NumAvatar).Y = Avatar(NumAvatar).PosYMini
If Avatar(NumAvatar).PosYMaxi <> 0 And Avatar(NumAvatar).Y > Avatar(NumAvatar).PosYMaxi Then _
    Avatar(NumAvatar).Y = Avatar(NumAvatar).PosYMaxi

' Si modification de la liste des images, risque de débordement de capacité:
If Avatar(NumAvatar).SpriteActif > UBound(Avatar(NumAvatar).ListeImages) Then _
            Avatar(NumAvatar).SpriteActif = UBound(Avatar(NumAvatar).ListeImages)
' Détermine l'image à afficher:
ImageNum = Avatar(NumAvatar).ListeImages(Avatar(NumAvatar).SpriteActif)

' Gère le Sprite Bloqué en horizontal:
If Avatar(NumAvatar).SpriteBloqué > 0 And Avatar(NumAvatar).MvX <> 0 Then
    If Avatar(NumAvatar).x = Avatar(NumAvatar).PosXMini _
    Or Avatar(NumAvatar).x = Avatar(NumAvatar).PosXMaxi _
    Then
        ImageNum = Avatar(NumAvatar).SpriteBloqué
    End If
End If

' Gère le Sprite Bloqué en vertical:
If Avatar(NumAvatar).SpriteBloqué > 0 And Avatar(NumAvatar).MvY <> 0 Then
    If Avatar(NumAvatar).Y = Avatar(NumAvatar).PosYMini _
    Or Avatar(NumAvatar).Y = Avatar(NumAvatar).PosYMaxi _
    Then
        ImageNum = Avatar(NumAvatar).SpriteBloqué
    End If
End If

' Copie l'avatar en mémoire temporaire s'il a été déclaré visible:
If Avatar(NumAvatar).Visible = True Then _
    Call CopieImage(ImageNum, ImgDest, Avatar(NumAvatar).x, Avatar(NumAvatar).Y)
    
' Recherche la prochaine image dans la liste des images du Sprite:
Avatar(NumAvatar).SpriteActif = Avatar(NumAvatar).SpriteActif + 1

' Gère la boucle des Sprite de l'avatar, sauf s'il ne faut pas faire de boucle:
If Avatar(NumAvatar).SpriteActif > UBound(Avatar(NumAvatar).ListeImages) Then
    If Avatar(NumAvatar).Animation = EnBoucle Or Avatar(NumAvatar).Animation > UneFoisEtQuitte Then
        Avatar(NumAvatar).SpriteActif = LBound(Avatar(NumAvatar).ListeImages)
    Else
        Avatar(NumAvatar).SpriteActif = UBound(Avatar(NumAvatar).ListeImages)
        ' Désactive l'avatar s'il faut quitter après la dernière image:
        If Avatar(NumAvatar).Animation = UneFoisEtQuitte Then Avatar(NumAvatar).Actif = False
    End If
End If

' Éventuellement, décrémente Avatar(NumAvatar).Animation pour atteindre la valeur UneFoisEtQuitte
If Avatar(NumAvatar).Animation > UneFoisEtQuitte Then _
                                 Avatar(NumAvatar).Animation = Avatar(NumAvatar).Animation - 1
                                 
' Retourne le numéro de l'image utilisée:
AnimeAvatar = ImageNum
End Function

XIII. Exemple d'animation avec le module Img

Reprenons l'animation du vol des trois canards que nous avons étudiée précédemment, en utilisant cette fois les procédures du module Img développées pour simplifier l'usage des API.
Pour mettre en pratique certaines de ces procédures, les canards volent désormais de droite à gauche et sont deux fois plus gros. J'ai aussi ajouté dans la boucle une condition pour masquer le canard lorsque la souris s'approche à moins de 50 pixels de son centre, et la possibilité de quitter l'animation en appuyant sur une touche. Enfin, le canard numéro 1 descend de 10 pixels toutes les demi-secondes.

Pour exécuter la procédure Descente qui décale l'ordonnée de l'avatar de 10 pixels toutes les demi-secondes, j'ai utilisé l'API SetTimer qui travaille en millisecondes, à la place de la fonction OnTime du VBA. La variable TimerID mémorise le pointeur de la fonction pour la désactiver avec l'API KillTimer.
Les déclarations sont :

 
Sélectionnez
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
                                        ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long

L'instruction qui lance la procédure Descente toutes les 500 millièmes de seconde est :

 
Sélectionnez
TimerID = SetTimer(0, 0, 500, AddressOf Descente)

À la fin de la boucle, l'événement est désactivé par l'instruction :

 
Sélectionnez
Call KillTimer(0, TimerID)

Pour quitter l'animation en appuyant sur n'importe quelle touche, j'utilise l'instruction :

 
Sélectionnez
If Img.ToucheEnfoncée(0) = True Then Call Img.AfficheImage(0): Exit Do

Après avoir ajouté la fonction ToucheEnfoncée dans le module Img :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Function ToucheEnfoncée(Optional VbKey As Long = 0) As Boolean
'---------------------------------------------------------------------------------------
' Retourne Vrai si la touche VbKey est enfoncée, ou si VbKey = 0 et qu'une touche
' (sauf y compris boutons souris 1 et 2) est enfoncée.
'---------------------------------------------------------------------------------------
Dim i As Integer
DoEvents
If GetKeyState(VbKey) < 0 Then ToucheEnfoncée = True: Exit Function
If VbKey = 0 Then
    For i = 3 To 127
        If GetKeyState(i) < 0 Then ToucheEnfoncée = True: Exit Function
    Next i
End If
End Function

Vous remarquerez dans le code qui suit que les images du Sprite du vol sont chargées avec en paramètre un alignement horizontal et vertical centré, ceci afin que les coordonnées de la souris correspondent au centre de l'image.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Sub NotionsDeBase()
'---------------------------------------------------------------------------------------
Call Img.InitialiseModeGraphique
 
' Chargement des 8 images du Sprite du vol:
For ImageNum = 1 To 8
    ' Charge l'image en mémoire temporaire numéro 100:
    Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\vol" & ImageNum & ".bmp", 10, -9)
    ' Retourne l'image numéro 10 et la place en mémoire 11 à 18:
    Call Img.TourneImage(10, 10 + ImageNum)
    ' Double la taille des images 11 à 18 qui serviront dans le Sprite:
    Call Img.ModifieTailleImage(10 + ImageNum, Image(10).Largeur * 2, Image(10).Hauteur * 2)
    ' Indique que l'image devra être centrée:
    Image(10 + ImageNum).AlignH = AlignH_Centre
    Image(10 + ImageNum).AlignV = AlignV_Centre
Next ImageNum

' Initialisation de la position aléatoire des 3 canards:
For i = 1 To 3
    Avatar(i).X = ImageMaxiX + Rnd() * 200  ' Position horizontale.
    Avatar(i).Y = Rnd() * 300               ' Position verticale.
    Avatar(i).SpriteActif = Rnd() * 14      ' Image du vol.
    Avatar(i).MvX = -10                     ' Vitesse de déplacement des canards.
    ' Initialisation de la liste des images qui composent le Sprite de l'avatar:
    Avatar(i).ListeImages = Array("11", "12", "13", "14", "15", "16", "17", "18", _
                                  "17", "16", "15", "14", "13", "12", "11")
    Avatar(i).Actif = True                  ' Déclare le canard actif.
    Avatar(i).Visible = True                ' Déclare le canard visible.
Next i

' Définit la procédure à exécuter dans 1/2 seconde:
TimerID = SetTimer(0, 0, 500, AddressOf Descente)

' Boucle tant qu'il reste un canard à l'écran, en incrémentant de 10 pixels vers la gauche:
Do
    ' Copie de la mémorisation de l'écran (mémoire 0) en mémoire de travail (mémoire -1):
    Call Img.CopieImage(0, -1)

    ' Déplace les canards en mémoire de travail -1:
    For i = 1 To 3: Call Img.AnimeAvatar(i, -1): Next i

    ' Affiche à l'écran la mémoire de travail -1 et fait une pause:
    Call Img.AfficheImage(-1)
    Call Sleep(40)

    ' Si la souris est près du centre du canard alors le canard devient invisible
    Call GetCursorPos(Pt)
    For i = 1 To 3
        Avatar(i).Visible = True
        If Abs(Avatar(i).X - Pt.X) < 50 And Abs(Avatar(i).Y - Pt.Y) < 50 Then Avatar(i).Visible = False
    Next i

    ' Si une touche est enfoncée alors remet l'écran d'origine et sort de l'animation:
     If Img.ToucheEnfoncée(0) = True Then Call Img.AfficheImage(0): Exit Do

Loop While Avatar(1).X > -100 Or Avatar(2).X > -100 Or Avatar(3).X > -100

' Ferme la procédure qui s'exécute toutes les 1/2 secondes:
Call KillTimer(0, TimerID)
 
' Fermeture du mode graphique:
Call Img.FermeModeGraphique

End Sub

'---------------------------------------------------------------------------------------
Sub Descente(ByVal hwnd As Long, ByVal uMsg As Long, ByVal IdEvent As Long, ByVal Systime As Long)
'---------------------------------------------------------------------------------------
Avatar(1).Y = Avatar(1).Y + 10
End Sub

Nous allons maintenant étudier l'animation d'un avatar où l'utilisateur intervient pour son déplacement.

Reprenons le Sprite du vol du canard où est ajoutée cette neuvième image : Image non disponible

La touche flèche de droite déplacera l'avatar vers la droite1, et la flèche de gauche vers la gauche2. Si ces touches ne sont pas enfoncées, le canard reste immobile et prend une forme d'attente3. Idem si l'avatar atteint la limite gauche ou droite de l'écran4.
La touche Fin fera chuter l'avatar5 (la neuvième image représentée ci-dessus) et mettra fin à l'animation7 après une explosion du canard6. Le Sprite de l'explosion est constitué de 7 images de 40 x 40 pixels8.

Image non disponible

Les images du Sprite du vol de gauche vers la droite, « Vol1.bmp » à « Vol8.bmp », sont chargées et alimentent les mémoires 11 à 189. Ces mémoires retournées forment le Sprite du vol en sens inverse, mémoires 21 à 2810. Toutes ces images sont initialisées centrées horizontalement et verticalement11. L'image du canard qui chute « Vol9.bmp » est chargée en mémoire 2012.

Le Sprite des 7 images de l'explosion contenu dans le fichier « Sprite_explosion.bmp » est chargé en mémoire 108. Une boucle est faite pour copier en mémoire 99 la fraction de l'image de 40 x 40 à récupérer13. Puis l'image est agrandie et copiée en mémoire 31 à 3714. Elle peut alors être déclarée centrée15.

L'avatar est initialisé au centre de l'écran, en ligne 300. L'écran est délimité avec une limite gauche et droite à 50 pixels du bord de l'écran16.

La boucle d'animation peut commencer17. Elle se terminera quand la touche Fin sera activée18, déclenchant en même temps l'animation de la chute de l'avatar et de son explosion.

Durant cette boucle, par défaut, l'avatar est immobile : MvX et MvY valent zéro. Donc l'image de l'avatar est soit la 14 soit la 24 suivant le sens de déplacement en cours19.

Si la touche flèche de droite est enfoncée1, alors le sens de déplacement en cours est alimenté à 10. Cela correspondra aussi au déplacement MvX. La liste des images de l'animation de l'avatar est alimentée par les images 11 à 18 et 17 à 1120. L'image 14 représente l'avatar bloqué dans son déplacement vers la droite21.

Si la touche flèche de gauche est enfoncée2, alors le sens de déplacement en cours est alimenté à -10. Cela correspondra aussi au déplacement MvX. La liste des images de l'animation de l'avatar est alimentée par les images 21 à 28 et 27 à 2122. L'image 24 représente l'avatar bloqué dans son déplacement vers la gauche23.

Tout est en place pour lancer l'animation de l'avatar.

Si une touche de direction reste enfoncée pendant la boucle, l'avatar sera donc animé normalement.

L'animation de la chute est très simple. Le déplacement MvX est annulé, et par contre MvY est alimenté à 10, pour une chute de 10 pixels par boucle24. Une seule image, numéro 20, est utilisée25. La boucle se termine quand l'avatar est à 50 pixels du bas de l'écran26.

L'explosion nécessite la présence des deux avatars, le canard et l'explosion27. Pour que le canard reste visible sur les quatre premières images de l'animation afin de simuler son explosion, son Animation est initialisée à 528. Ainsi elle sera jouée jusqu'à 2 :

Image non disponible Image non disponible Image non disponible Image non disponible Image non disponible Image non disponible

L'animation de l'explosion est déclarée UneFoisEtQuitte29, donc à sa fin Actif prend la valeur False et indique que la boucle de l'animation peut être quittée30.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Sub NotionsDeBase()
'---------------------------------------------------------------------------------------
Call Img.InitialiseModeGraphique
Dim SensAvatar As Integer

' Chargement des 8 images du Sprite du vol:
For ImageNum = 1 To 8                                                                               ' 9
    ' Charge l'image en mémoire 11 à 18:
    Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\vol" & ImageNum & ".bmp", _
                        ImageNum + 10, -9, AlignH_Centre, AlignV_Centre)
    ' Retourne l'image numéro et la place en mémoire 21 à 28:                                       ' 11
    Call Img.TourneImage(ImageNum + 10, ImageNum + 20)                                              ' 10
Next ImageNum

' Charge l'image du canard qui chute :                                                              ' 12
Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\vol9.bmp", 20, -9, AlignH_Centre, AlignV_Centre)

' Charge le Sprite de l'explosion (7 images de 40x40) en mémoire 10:
Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\Sprite_explosions.bmp", 10, -9, 0, 0)               ' 8

' Récupère les 7 images du Sprite:
For ImageNum = 0 To 6
    ' Copie la fraction d'image en mémoire temporaire 99:                                           ' 13
    Call Img.CopieImage(10, 99, 0, 0, ImageNum * 40, 0, 40, 40)
    ' Modifie la taille de l'image 99 et crée l'image 31 à 37:
    Call Img.ModifieTailleImage(99, 80, 80, 31 + ImageNum)                                          ' 14
    ' Déclare que les images 31 à 37 seront centrées:
    Image(31 + ImageNum).AlignH = AlignH_Centre                                                     ' 15
    Image(31 + ImageNum).AlignV = AlignV_Centre
    ' Efface la mémoire temporaire 99:
    Call Img.EffaceImage(99)
Next ImageNum

' Initialisation de l'avatar 0, qui représente le canard:
Avatar(0).X = ImageMaxiX / 2            ' Position horizontale.                                     ' 16
Avatar(0).Y = 300                       ' Position verticale.
Avatar(0).PosXMini = 50                 ' Limite gauche
Avatar(0).PosXMaxi = ImageMaxiX - 50    ' Limite droite
Avatar(0).Actif = True                  ' Déclare le canard actif.
Avatar(0).Visible = True                ' Déclare le canard visible.

Do                                                                                                  ' 17
    ' Copie de la mémorisation de l'écran (mémoire 0) en mémoire de travail (mémoire -1):
    Call Img.CopieImage(0, -1)
    
    ' Si aucune flèche enfoncée alors l'avatar reste immobile :                                     ' 3
    Avatar(0).MvX = 0
    If SensAvatar < 0 Then                                                                          ' 19
        Avatar(0).ListeImages = Array("24") ' Image si immobile vers la gauche.
    Else                                                                                            ' 4
        Avatar(0).ListeImages = Array("14") ' Image si immobile vers la droite.
    End If
        
    ' Si flèche droite, alors définit le sprite du vol vers la droite:
    If Img.ToucheEnfoncée(vbKeyRight) = True Then                                                   ' 1
        SensAvatar = 10             ' Mémorise le sens de déplacement en cours.
        Avatar(0).ListeImages = Array("11", "12", "13", "14", "15", "16", "17", "18", _             ' 20
                                      "17", "16", "15", "14", "13", "12", "11")
        Avatar(0).SpriteBloqué = 14 ' Image si l'avatar atteint la limite droite.                   ' 21
        Avatar(0).MvX = SensAvatar  ' Déplace l'avatar.
    End If
    
    ' Si flèche gauche, alors définit le sprite du vol vers la gauche:
    If Img.ToucheEnfoncée(vbKeyLeft) = True Then                                                    ' 2
        SensAvatar = -10            ' Mémorise le sens de déplacement en cours.
        Avatar(0).ListeImages = Array("21", "22", "23", "24", "25", "26", "27", "28", _             ' 22
                                      "27", "26", "25", "24", "23", "22", "21")
        Avatar(0).SpriteBloqué = 24 ' Image si l'avatar atteint la limite gauche.                   ' 23
        Avatar(0).MvX = SensAvatar  ' Déplace l'avatar.
    End If
    
    ' Déplace l'avatar en mémoire de travail -1:
    Call Img.AnimeAvatar(0, -1)
    
    ' Si l'avatar est immobile, en cas de déplacement commencera à la 11e image:
     If Avatar(0).MvX = 0 Then Avatar(0).SpriteActif = 11
    
    ' Affiche à l'écran la mémoire de travail -1 et fait une pause:
    Call Img.AfficheImage(-1)
    Call Sleep(40)
    
    ' Si une touche Fin est enfoncée alors sort de l'animation:
     If Img.ToucheEnfoncée(vbKeyEnd) = True Then Call Chute: Call Explosion: Exit Do                ' 7
                                        '  18           5            6
Loop

' Fermeture du mode graphique:
Call Img.FermeModeGraphique

End Sub

'---------------------------------------------------------------------------------------
Sub Chute()
'---------------------------------------------------------------------------------------
Avatar(0).MvX = 0                                   ' 24
Avatar(0).MvY = 10
Avatar(0).ListeImages = Array("20")                 ' 25
Do
    Call Img.CopieImage(0, -1)
    Call Img.AnimeAvatar(0, -1)
    Call Img.AfficheImage(-1)
    Call Sleep(40)
Loop While Avatar(0).Y + 50 < ImageMaxiY            ' 26
End Sub

'---------------------------------------------------------------------------------------
Sub Explosion()
'---------------------------------------------------------------------------------------
' Initialisation de l'avatar 1 qui représente l'explosion:
Avatar(1).X = Avatar(0).X
Avatar(1).Y = Avatar(0).Y
Avatar(1).Actif = True                                                      ' 27
Avatar(1).Visible = True
Avatar(1).Animation = UneFoisEtQuitte                                       ' 29
Avatar(1).ListeImages = Array("31", "32", "33", "34", "35", "36", "37")

' Annule le déplacement du canard et l'affichera trois dernières fois:
Avatar(0).MvX = 0
Avatar(0).MvY = 0                                                           ' 27
Avatar(0).SpriteActif = 0
Avatar(0).ListeImages = Array("20")                                         ' 28
Avatar(0).Animation = 5

' Boucle tant que le Sprite de l'explosion n'est pas terminé:
Do
    Call Img.CopieImage(0, -1)
    
    Call Img.AnimeAvatar(0, -1) ' Avatar du canard.
    Call Img.AnimeAvatar(1, -1) ' Avatar de l'explosion.
    
    Call Img.AfficheImage(-1)
    Call Sleep(100)

Loop While Avatar(1).Actif = True                                           ' 30

' Affiche l'écran d'origine:
Call Img.AfficheImage(0)
End Sub

XIV. Utiliser un formulaire pour les animations

En mixant ces deux exemples d'animation, il serait tentant de faire un jeu de tir aux canards en se servant de la souris pour faire exploser les canards en vol.
J'ai bien essayé, mais malheureusement ça ne marche pas, car chaque clic donne la main à la feuille de calcul ouverte, ou à l'application d'arrière-plan, et le clic de la souris n'est pas reconnu par notre code.

Alors que faire ?

La première astuce est d'utiliser un formulaire (voir le tome 1 pour plus d'informations sur la création d'un formulaire), et de bloquer la souris dans l'espace du formulaire pour nous assurer que le clic sera reconnu par notre code.
La seconde astuce est de remplacer le contexte de l'écran par le contexte du formulaire, créant de ce fait un écran bis, et le formulaire, totalement indépendant de l'écran principal, pourra même être déplacé librement, sans incidence sur l'animation.
Cerise sur le gâteau, toutes nos procédures restent compatibles.

Voici un aperçu de ce que nous obtiendrons :

Image non disponible

La procédure InitialiseModeGraphique doit être modifiée pour gérer la possibilité de travailler dans un formulaire (passé en argument), et tant que l'on y est, pour éventuellement centrer ce formulaire avec une marge horizontale et verticale désirée…

L'API FindWindowA avec en arguments le type de classe ThunderDFrame et le libellé du formulaire, retourne le numéro de la fenêtre du formulaire. Numéro qui sera converti avec l'API GetDC pour obtenir le numéro du contexte du formulaire.

 
Sélectionnez
Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, 
                                           ByVal lpWindowName As String) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Les coordonnées (Top, Left) et les dimensions internes (InsideHeight, InsideWidth) ou externes (Height, Width) d'un formulaire sont exprimées en points et non en pixels. Des conversions seront donc nécessaires pour appliquer une marge à l'affichage du formulaire et modifier sa taille. L'API GetDeviceCaps indique, suivant la résolution utilisée, le nombre de points par pixel et permet ces conversions.

 
Sélectionnez
Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As Long

nIndex = LOGPIXELSX (88) pour la résolution horizontale et LOGPIXELSY (90) pour la résolution verticale.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Function PointsEnPixelsX(lPoint As Long) As Long
'---------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 88) ' LOGPIXELSX
PointsEnPixelsX = CLng(lPoint / Mult)
End Function

'---------------------------------------------------------------------------------------
Public Function PointsEnPixelsY(lPoint As Long) As Long
'---------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 90) ' LOGPIXELSY
PointsEnPixelsY = CLng(lPoint / Mult)
End Function

'---------------------------------------------------------------------------------------
Public Function PixelsEnPointsX(lPixel As Long) As Long
'---------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 88) ' LOGPIXELSX
PixelsEnPointsX = CLng(lPixel * Mult)
End Function

'---------------------------------------------------------------------------------------
Public Function PixelsEnPointsY(lPixel As Long) As Long
'---------------------------------------------------------------------------------------
Static Mult As Single
If Mult = 0 Then Mult = 72 / GetDeviceCaps(GetWindowDC(0), 90) ' LOGPIXELSY
PixelsEnPointsY = CLng(lPixel * Mult)
End Function

Nous utiliserons aussi ces procédures pour bloquer la souris dans l'espace du formulaire :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub BloqueCurseurDansForm(ObjFormulaire As Object)
'---------------------------------------------------------------------------------------
SourisBloque.Top = PointsEnPixelsX(ObjFormulaire.Top)
SourisBloque.Left = PointsEnPixelsY(ObjFormulaire.Left)
SourisBloque.Bottom = PointsEnPixelsY(ObjFormulaire.Top + ObjFormulaire.Height)
SourisBloque.Right = PointsEnPixelsX(ObjFormulaire.Left + ObjFormulaire.Width)
Call ClipCursor(SourisBloque)
End Sub

Et inversement, pour savoir où se situe la souris dans le formulaire en tenant compte du décalage entre l'origine 0,0 de l'écran et l'origine 0,0 du formulaire :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub LectureCurseurDansForm(Pt As POINT, ObjFormulaire As Object)
'---------------------------------------------------------------------------------------
Call GetCursorPos(Pt)
Pt.x = Pt.x - PointsEnPixelsX(ObjFormulaire.Left)
Pt.Y = Pt.Y - PointsEnPixelsY(ObjFormulaire.Top)
End Sub

Voici donc la nouvelle version de la procédure d'initialisation du mode graphique :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub InitialiseModeGraphique(Optional ObjFormulaire As Object, _
           Optional MargeH As Long = -1, Optional MargeV As Long = -1)
'---------------------------------------------------------------------------------------
Call EffaceImage(-1): Call EffaceImage(0)

If ObjFormulaire Is Nothing Then ' Si pas de formulaire, donc utilise l'écran:
    Hdc = GetWindowDC(0)             ' Mémorise le contexte de l'écran.
    ImageMaxiX = GetSystemMetrics(0) ' Mémorise la taille horizontale de l'écran.
    ImageMaxiY = GetSystemMetrics(1) ' Mémorise la taille verticale de l'écran.
Else
    ' Mémorise le contexte du formulaire (classe Windows suivant version EXCEL):
    Hdc = FindWindowA("ThunderDFrame", ObjFormulaire.Caption) ' "ThunderXFrame" si < 2002.
    Hdc = GetDC(Hdc)
    If MargeH > -1 Then ' S'il faut afficher le formulaire avec une marge horizontale:
        ObjFormulaire.Left = PixelsEnPointsX(MargeH)
        ObjFormulaire.Width = PixelsEnPointsX(GetSystemMetrics(0) - MargeH * 2)
    End If
    If MargeV > -1 Then ' S'il faut afficher le formulaire avec une marge verticale:
        ObjFormulaire.Top = PixelsEnPointsY(MargeV)
        ObjFormulaire.Height = PixelsEnPointsY(GetSystemMetrics(1) - MargeV * 2)
    End If
    ' Mémorise les dimensions maximales du formulaire (en pixels):
    ImageMaxiX = PointsEnPixelsX(ObjFormulaire.InsideWidth)  ' Taille horizontale.
    ImageMaxiY = PointsEnPixelsY(ObjFormulaire.InsideHeight) ' Taille verticale.
    ' Redessine le formulaire à l'écran:
    ObjFormulaire.Repaint
End If

' Création de l'image 0 pour mémoriser l'écran d'origine:
Call CopieImage(0, 0, , , , , ImageMaxiX, ImageMaxiY)
Image(0).Transparence = -1 ' Sans transparence.
 
' Mémorise l'écran en mémoire 0 puis fait une copie en mémoire -1:
Call BitBlt(Image(0).Hdc, 0, 0, ImageMaxiX, ImageMaxiY, Hdc, 0, 0, SRCCOPY)
Call CopieImage(0, -1)

' Mémorise l'espace de déplacement de la souris:
Call GetClipCursor(SourisEspace)
End Sub

La procédure de fermeture du mode graphique utilise les API : GetActiveWindow qui retourne la fenêtre active, GetClassName pour vérifier si cette fenêtre est un formulaire, et PostMessage pour la fermer.

Ces API pourront vous être utiles dans vos autres applications, il faut donc les connaître :

 
Sélectionnez
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
                 ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, _
                 ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'---------------------------------------------------------------------------------------
Public Sub FermeModeGraphique()
'---------------------------------------------------------------------------------------
' Libère les mémoires:
For ImageNum = -1 To UBound(Image()): Call EffaceImage(ImageNum): Next ImageNum
ReleaseDC 0, Hdc
Call ShowCursor(1)              ' Affiche le curseur de la souris.
Call ClipCursor(SourisEspace)   ' Restaure l'espace de déplacement de la souris.

' Ferme la fenêtre active si la fenêtre active est un formulaire:
Dim ClassName As String * 256
Call GetClassName(GetActiveWindow(), ClassName, 256) ' ClassName contient le nom de la classe
If Left(ClassName, 13) = "ThunderDFrame" Then Call PostMessage(GetActiveWindow(), &H10, 0, 0)

' Restaure la résolution graphique d'origine:
Call ChangeScreen_Resolution(0, 0)
End Sub

La dernière instruction de FermeModeGraphique lance la fonction ChangeScreen_Resolution(Largeur, Hauteur), qui mérite quelques explications, car elle aussi peut vous être très utile.
Comme son nom l'indique, cette fonction permet de changer la résolution graphique de l'écran.
Ce peut être nécessaire si votre application est construite pour afficher à l'écran un certain nombre de pixels : une résolution trop petite fera déborder l'affichage de l'écran et inversement une résolution trop grande rendra l'affichage illisible.
Si la résolution passée en arguments est supportée par l'écran, la résolution est modifiée et la fonction retourne True. Sinon rien ne se passe et la fonction retourne False. Les résolutions les plus courantes sont : VGA 640x480, SVGA 800x600, XGA 1024x768, SXGA 1280x1024, UXGA 1600x1200.

Avant de modifier la résolution graphique de l'écran, les valeurs d'origine sont sauvegardées dans les variables publiques Anc_ScrWidth et Anc_ScrHeight.
La résolution d'origine est restituée lorsque les arguments passés à la fonction sont 0, 0, ce que fait la procédure FermeModeGraphique au cas où un changement de résolution ait été fait.

La fonction fait appel aux API EnumDisplaySettings pour mémoriser la configuration de l'écran dans la structure TypDevMODE et ChangeDisplaySettings pour modifier cette configuration.

 
Sélectionnez
Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
                 (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
                 (lptypDevMode As Any, ByVal dwFlags As Long) As Long

La procédure du module Img s'inspire du code que vous trouverez sur la page « www.mrexcel.com/archive/VBA/29971.html », qui détaille aussi la structure TypDevMODE.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Function ChangeScreen_Resolution(ScrWidth As Long, ScrHeight As Long) As Boolean
'---------------------------------------------------------------------------------------
' Mémorise la résolution avant de la changer:
If Anc_ScrWidth = 0 Then Anc_ScrWidth = GetSystemMetrics(0)
If Anc_ScrHeight = 0 Then Anc_ScrHeight = GetSystemMetrics(1)

' Si pas de valeur indiquée dans les arguments alors restaure la résolution d'origine:
If ScrWidth + ScrHeight = 0 Then
    ScrWidth = Anc_ScrWidth
    ScrHeight = Anc_ScrHeight
End If

' Si la résolution demandée est déjà celle existante alors rien à faire et quitte:
If ScrWidth = GetSystemMetrics(0) And ScrHeight = GetSystemMetrics(1) Then _
    ChangeScreen_Resolution = True: Exit Function

' Mémorise dans TypDevM la configuration de l'écran en utilisant la structure TypDevMODE:
Dim TypDevM As TypDevMODE
Call EnumDisplaySettings(0, 0, TypDevM)
' Change les valeurs de TypDevM:
TypDevM.dmFields = &H80000 Or &H100000
TypDevM.dmPelsWidth = ScrWidth
TypDevM.dmPelsHeight = ScrHeight

' Change la résolution en passant en argument TypDevM:
If ChangeDisplaySettings(TypDevM, &H4) = 0 Then ChangeScreen_Resolution = True
End Function

Exemple pour passer en résolution WXGA 1280x800 et afficher un message en cas d'erreur :

 
Sélectionnez
If Img.ChangeScreen_Resolution(1280, 800) = False Then
    MsgBox "La résolution 1280 x 800 n'est pas supportée par votre écran" _
            & Chr(10) & Chr(13) & "L'affichage risque d'être perturbé."
End If

Nous pouvons maintenant créer ce fameux jeu de tir aux canards, à partir d'un formulaire assez grand, où j'ai incorporé une image de fond. Pour compléter l'animation, j'ai ajouté du son sur le tir « laser-01.wav », et pendant l'explosion « fire-04-loop.wav », ainsi qu'un texte, « BRAVO » ou « ENCORE RATÉ », géré comme un avatar, qui s'affiche lors du clic, et un chronomètre.

Le formulaire possède le bouton « CommandButton1 » qui lance la procédure d'animation ImgDansUnFormulaire contenue dans un module ordinaire. L'objet Formulaire étant passé en argument :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
CommandButton1.Visible = False      ' Masque le bouton de lancement.
Call ImgDansUnFormulaire(Me)        ' Lance l'animation dans le formulaire.
End Sub

'---------------------------------------------------------------------------------------
Public Sub ImgDansUnFormulaire(MyForm As Object)
'---------------------------------------------------------------------------------------
' Initialise le mode graphique pour travailler dans un formulaire:
Call Img.InitialiseModeGraphique(MyForm, 100, 100) ' Formulaire centré avec une marge de 100

' Chargement des 8 images du Sprite du vol:
For ImageNum = 1 To 8
    ' Charge l'image en mémoire 11 à 18:
    Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\vol" & ImageNum & ".bmp", _
                            ImageNum + 10, -9, AlignH_Centre, AlignV_Centre)
Next ImageNum

' Charge le Sprite de l'explosion (7 images de 40x40) en mémoire 10:
Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\Sprite_explosions.bmp", 10, -9, 0, 0)

' Récupère les 7 images du Sprite de l'explosion:
For ImageNum = 0 To 6
    ' Copie la fraction d'image en mémoire temporaire 99:
    Call Img.CopieImage(10, 99, 0, 0, ImageNum * 40, 0, 40, 40)
    ' Modifie la taille de l'image 2 et crée l'image 31 à 37:
    Call Img.ModifieTailleImage(99, 80, 80, 31 + ImageNum)
    ' Déclare que les images 31 à 37 seront centrées:
    Image(31 + ImageNum).AlignH = AlignH_Centre
    Image(31 + ImageNum).AlignV = AlignV_Centre
    ' Efface la mémoire temporaire 99:
    Call Img.EffaceImage(99)
Next ImageNum

' Charge l'image du viseur, le viseur sera centré à l'affichage:
Call Img.ChargeImageBMP(ActiveWorkbook.Path & "\Viseur.bmp", 99, -1)
Call Img.ModifieTailleImage(99, 30, 30) ' Nouvelle Taille du viseur.
Image(99).AlignH = AlignH_Centre
Image(99).AlignV = AlignV_Centre
Image(99).Transparence = GetPixel(Image(99).Hdc, 0, 0)

' Masque la souris:
Call ShowCursor(0)

' Initialisation de l'avatar 0, qui représente le canard:
Avatar(0).X = -100 * Rnd         ' Position horizontale.
Avatar(0).Y = 100 + Rnd * 300    ' Position verticale.
Avatar(0).MvX = 10               ' Déplacement de l'avatar.
Avatar(0).Actif = True           ' Déclare le canard actif.
Avatar(0).Visible = True         ' Déclare le canard visible.
Avatar(0).ListeImages = Array("11", "12", "13", "14", "15", "16", "17", "18", _
                              "17", "16", "15", "14", "13", "12", "11")
                              
 ' Initialise l'avatar 2 qui sera le texte affiché après un tir:
Call Img.TexteConfig(0, 0, -1, "Arial", 30, 900)
Avatar(2).Actif = False
Avatar(2).Visible = True
Avatar(2).ListeImages = Array("10")
Avatar(2).MvY = 5

' Configuration du texte pour l'affichage du chronomètre
Call Img.TexteConfig(1, 15, 0, "Arial", 20)

' Définit la procédure du chronomètre à exécuter toutes les secondes:
TimerID = SetTimer(0, 0, 1000, AddressOf AfficheTemps) ' Procédure à exécuter.
Call AfficheTemps(0, 0, 0, 0) ' Affiche dès maintenant sans attendre une seconde.

On Error GoTo Fin ' Si le formulaire est fermé.
Do
    ' Bloque la souris dans le cadre du formulaire, qui peut être déplacé à tout moment:
    Call Img.BloqueCurseurDansForm(MyForm)
    
    ' Copie de la mémorisation de l'écran (mémoire 0) en mémoire de travail (mémoire -1):
    Call Img.CopieImage(0, -1)
    
    ' Lecture du bouton gauche de la souris:
     If Img.ToucheEnfoncée(vbKeyLButton) = True Then
        Avatar(2).Actif = True
        Avatar(2).X = Pt.X: Avatar(2).Y = Pt.Y + 50:
        Avatar(2).Animation = 20
        Call Img.EffaceImage(10)
        Call Img.CopieImage(10, 10, , , , , Police(0).Taille * 10, Police(0).Taille)
        
        ' Son du tir:
        Call PlaySound(ThisWorkbook.Path & "\laser-01.wav", pcsASYNC)
        
        ' Si l'avatar est touché alors provoque son explosion:
        If Abs(Avatar(0).X - Pt.X) < 20 And Abs(Avatar(0).Y - Pt.Y) < 20 Then
            Call Img.Texte(Image(10).Hdc, 0, 0, "BRAVO")
            Explosion
            ' Relance un nouvel avatar pour ne pas terminer le jeu:
            Avatar(0).X = -100 + Rnd * 100   ' Position horizontale.
            Avatar(0).Y = 100 + Rnd * 200    ' Position verticale.
            Avatar(0).MvX = 10               ' Déplacement.
            Avatar(0).Actif = True           ' Activation.
        Else
            ' Sinon affiche juste un message:
            Call Img.Texte(Image(10).Hdc, 0, 0, "ENCORE RATÉ")
        End If
     End If
    
    ' Copie ou non le message suite au clic:
    Call Img.AnimeAvatar(2, -1)
    
    ' Déplace l'avatar en mémoire de travail -1:
    Call Img.AnimeAvatar(0, -1)
    
    ' Lecture de la position du curseur et correction d'après l'origine du formulaire:
    Call Img.LectureCurseurDansForm(Pt, MyForm)
    
     ' Copie le viseur en mémoire de travail:
    Call Img.CopieImage(99, -1, Pt.X, Pt.Y)
    
    ' Affiche à l'écran la mémoire de travail -1 et fait une pause:
    Call Img.AfficheImage(-1)
    Call Sleep(40)
    
    ' Si la touche Fin est enfoncée alors sort de l'animation:
     If Img.ToucheEnfoncée(vbKeyEnd) = True Then Exit Do

Loop While Avatar(0).X < ImageMaxiX + 100 ' Quitte si le canard sort de l'écran.

Fin:
' Ferme la procédure qui s'exécute toutes les secondes:
Call KillTimer(0, TimerID)
' Fermeture du mode graphique:
Call Img.FermeModeGraphique

End Sub

'---------------------------------------------------------------------------------------
Sub Explosion()
'---------------------------------------------------------------------------------------
' Initialisation de l'avatar 1 qui représente l'explosion:
Avatar(1).X = Pt.X
Avatar(1).Y = Pt.Y
Avatar(1).Actif = True
Avatar(1).Visible = True
Avatar(1).SpriteActif = 0
Avatar(1).Animation = UneFoisEtQuitte
Avatar(1).ListeImages = Array("31", "32", "33", "34", "35", "36", "37")

' Annule le déplacement du canard et l'affichera 3 fois:
Avatar(0).MvX = 0
Avatar(0).SpriteActif = 0

' Fait une pause pour entendre la fin du son du tir:
Call Sleep(100)

' Son de l'explosion, joué en boucle:
Call PlaySound(ThisWorkbook.Path & "\fire-04-loop.wav", pcsLOOP + pcsASYNC)

' Boucle tant que le Sprite de l'explosion n'est pas terminé:
Do
    Call Img.CopieImage(0, -1)  ' Copie la mémoire de l'écran en mémoire -1.
    Call Img.AnimeAvatar(0, -1) ' Anime l'avatar du canard.
    Call Img.AnimeAvatar(1, -1) ' Anime l'avatar de l'explosion.
    Call Img.AnimeAvatar(2, -1) ' Anime l'avatar du texte affiché.
    
    Call Img.AfficheImage(-1)   ' Affiche la mémoire de travail.
    Call Sleep(100)             ' Fait une pause.
    
    If Avatar(0).SpriteActif = 3 Then Avatar(0).Actif = False ' Affiche l'avatar que 3 fois.

Loop While Avatar(1).Actif = True
Call PlaySound(" ", pcsASYNC) ' Fin du son de l'explosion joué en boucle.

End Sub

'---------------------------------------------------------------------------------------
Sub AfficheTemps(ByVal hwnd As Long, ByVal uMsg As Long, ByVal IdEvent As Long, _
                 ByVal Systime As Long)
'---------------------------------------------------------------------------------------
Static Chrono As Double
If Chrono = 0 Then Chrono = Timer ' Mémorise l'heure de début.

' Affiche le temps écoulé depuis l'heure mémorisée dans la variable Chrono:
Call Img.Texte(Image(0).Hdc, 1, ImageMaxiY - Police(1).Taille, _
               Format((Timer - Chrono) / 100000, "nn:ss"), 1) ' Format "minutes:secondes"
End Sub

Nous obtenons ceci.
Il est vrai que c'est sans grand intérêt.
Mais le but était avant tout d'acquérir, progressivement, les notions et les outils nécessaires à la création d'un véritable jeu d'arcade.
Ce sera notre prochaine étape.

Image non disponible

XV. Snake - Programmer un jeu d'arcade en mode graphique

Le tome 1 présentait un code pour programmer le jeu d'arcade Snake avec les fonctionnalités du VBA.

Je vous rappelle le principe : avec les touches du clavier « flèche gauche » et « flèche droite », vous déplacez un serpent qui doit manger dix pommes pour passer au niveau suivant. Pour compliquer la tâche du joueur, chaque pomme mangée rallonge le serpent et les niveaux comportent de plus en plus d'obstacles à éviter.

Nous allons reprendre la programmation de ce jeu, cette fois en mode graphique, vous constaterez ainsi la différence.

Voici le rendu de la programmation en mode standard…

Image non disponible

Et le rendu que nous allons obtenir en mode graphique.

Image non disponible

Cela peut vous surprendre, mais ces deux versions ont beaucoup de points communs. En effet, la version en mode graphique utilise un « masque », pour lire la position des avatars sur le plateau.

Chargé en mémoire Masque(X,Y), il est alimenté de valeurs qui représentent un vide ou un objet : mur, pomme, corps du serpent, porte. C'est la lecture du masque qui permet de déterminer l'image qui doit être affichée sur le plateau et aussi de connaître les objets rencontrés.

Dans le masque ci-dessus, quand la tête du serpent est en position X=5, Y=17, c'est que le serpent est rentré dans un mur. Et la pomme est en position X=22, Y=22. On retrouve les mêmes notions que la programmation en mode standard, sauf que le masque est en mémoire alors qu'en mode standard on utilise directement les informations de la feuille de calcul. Ainsi Masque(X,Y) est l'équivalent de Cells(Y,X).

Dans notre jeu, c'est une feuille de calcul qui permet d'initialiser le masque d'un niveau. Vous pouvez donc facilement créer des niveaux à volonté.

Pour une meilleure compréhension du code, j'ai repris la liste des images utilisées par le jeu :

11 à 30 : le Sprite du serpent avec ses différents sens de déplacement.
Qui comprend aussi la pomme, 26, qui sera l'avatar numéro 10, la porte du bas, 27, qui sera l'avatar numéro 11, et la porte du haut, 28, qui sera l'avatar numéro 12.
Un vide est représenté par l'image 22.

Image non disponible

31 : le mur.

Image non disponible

41 à 47 : le Sprite des pièces.
C'est l'avatar numéro 8.

Image non disponible

51 à 62 : le Sprite du trooper.
C'est l'avatar numéro 9.

Image non disponible Image non disponible

81 à 87 : le Sprite de l'explosion.
C'est l'avatar numéro 0.

Image non disponible

98 : le fond d'écran d'origine où sera posé le plateau de jeu.
99 : le plateau du jeu avec les murs du niveau.
100 : mémoire de travail du plateau pour poser le serpent.

 

Le tableau des scores est composé de 7 affichages qui sont gérés comme des avatars (numéros 101 à 107) ne contenant qu'une image, et utilisent les mémoires suivantes :

101 : image où est affiché le niveau.
102 : image où sont affichés les points.
103 : image où sont affichées les vies restantes.
104 : image où est affiché le nombre de pommes mangées dans le niveau.
105 : image où est affichée la durée du jeu.
106 : image où est affiché le compte à rebours du bonus pour gagner des points supplémentaires.
107 : image où est affiché un commentaire.

Quand un score doit être mis à jour, le fond d'origine de l'écran (mémoire 0) où est posé l'avatar est copié dans l'image associée à l'avatar. Puis le texte est écrit dans cette mémoire. L'animation de l'avatar, UneFoisEtAffiche, déclenche d'office l'affichage de la valeur.
C'est la technique que nous avons utilisée dans le tir aux canards. Plus simple que la méthode qui consiste à réécrire à chaque fois le texte de l'intégralité du tableau du score en mémoire de travail.

Pour déplacer le serpent dans le masque, sa position est mémorisée dans une structure :

 
Sélectionnez
Type TypeSerpent
    X As Integer
    Y As Integer
    Forme As String * 1
End Type
Public Serpent(0 To 200) As TypeSerpent

X et Y sont les coordonnées, Forme est un code qui est déterminé par la direction de déplacement : H si le serpent se dirige vers le haut (MvY=-1), B vers le bas (MvY=1), G vers la gauche (MvX=-1), D vers la droite (MvX=1).
L'indice 0 représente la tête du serpent, les autres indices représentent le corps.

Le déplacement du serpent se décompose en plusieurs étapes, dont voici les grandes lignes :

  • Le déplacement de la tête, indice 0, suivant la direction active, avec mise à jour du masque.
  • Le déplacement du corps, à rebours en partant de la queue, pour que chaque indice prenne la place de l'indice précédent, avec bien sûr la mise à jour du masque.
  • Le masque de l'ancien emplacement de la queue peut alors être marqué comme libre.
  • Reste maintenant à afficher le serpent, en commençant par la tête.
  • Suivant la direction mémorisée dans Serpent(0).Forme, l'image à afficher sera soit la 14, la 15, la 19, la 20.
  • Même principe pour le corps, qui n'a lui que deux images, 12 et 18, pour les quatre directions possibles.
  • Mais attention, le corps peut prendre un virage. Il faut donc comparer l'indice avec l'indice suivant, et en fonction du sens du virage, utiliser l'image 11, 13, 16, ou 23.
  • Et enfin la queue.
  • Le traitement des éléments du corps du serpent se fait en mémoire 100.
  • Puis cette mémoire est reversée dans la mémoire de travail -1.
  • Mémoire où viendra s'ajouter l'animation des 12 avatars.
  • Avant que le tout soit affiché à l'écran.
  • La lecture des touches enfoncées permet de détecter un changement de direction, et si c'est le cas de modifier la direction active.

Le formulaire de lancement, User_ImgSnake, est non modal, c'est important pour la suite.
Il contient le bouton CommandButton1, qui permet de lancer la procédure publique ImgSnake(MyForm As Object) contenue dans un module classique :

 
Sélectionnez
'---------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
CommandButton1.Visible = False  ' Masque le bouton de lancement.
Call ImgSnake(Me)               ' Lance l'animation dans le formulaire.
End Sub

Je vous présente, dans ce qui suit, le code du jeu, en commençant par la déclaration des variables, leur initialisation, l'initialisation des niveaux, avant d'attaquer le cœur de l'animation.

Vous connaissez déjà les procédures du module Img utilisées (sauf une que je vous présenterai après) et le reste ne pose pas de problème, car les commentaires vous guideront.

Bonne lecture.

Code du jeu
CacherSélectionnez

J'ai créé la procédure TexteDéfilement, que vous trouverez dans le module Img, pour répondre au besoin du jeu, où il fallait afficher les 10 meilleurs scores, voire plus, dans un espace limité en lignes.

La seule façon est de faire défiler les lignes à la manière d'un rouleau qui tourne sur lui-même.

L'affichage peut être fait dans un formulaire, comme ici :
Mais cela nécessite que le formulaire qui lance le jeu soit en mode non modal, pour accepter la présence d'un deuxième formulaire.

Image non disponible

Ou bien dans une image, comme ici :

Image non disponible

Les arguments de la procédure sont :

  • X, Y : coordonnées d'affichage du formulaire ou de l'image ;
  • Largeur, Hauteur : dimension de du formulaire ou de l'image ;
  • Titre : titre ;
  • PoliceTitre : numéro du modèle de police, créé par TexteConfig, à utiliser pour le titre ;
  • CouleurFond : couleur de fond de l'affichage ;
  • ListeTextes : tableau des lignes de texte à afficher ;
  • ListePolices : tableau des numéros de modèle de polices à utiliser pour ces lignes ;
  • ObjFormulaire : argument optionnel, est le nom du formulaire à utiliser pour l'affichage ;
  • DuréePause : argument optionnel, est la durée, en millisecondes, de la pause entre deux défilements.

Vous avez sur la page précédente un exemple d'appel à cette procédure.

 
Sélectionnez
'---------------------------------------------------------------------------------------
Public Sub TexteDéfilement(ByVal X As Long, ByVal Y As Long, _
           Largeur As Long, Hauteur As Long, _
           Titre As Variant, PoliceTitre As Byte, ByVal CouleurFond As Long, _
           ListeTextes As Variant, ListePolices As Variant, _
           Optional ByVal ObjFormulaire As Object, Optional DuréePause As Long = 60)
'---------------------------------------------------------------------------------------
' Attention : Utilisation des mémoires 1, 2 et 3
'---------------------------------------------------------------------------------------
Dim YY As Long, i As Integer, Taille As Long, MémoSourisEspace As RECT

' Mémorise l'espace souris actif, et le contexte actif:
Call GetClipCursor(MémoSourisEspace)
Anc_Hdc = Hdc

' Si utilisation d'un formulaire, trouve son contexte et lui donne les dimensions désirées:

If Not ObjFormulaire Is Nothing Then
    Hdc = GetDC(FindWindowA("ThunderDFrame", ObjFormulaire.Caption))
    Call ObjFormulaire.Show(False)
    ObjFormulaire.Left = X: X = 0
    ObjFormulaire.Top = Y: Y = 0
    ObjFormulaire.Height = Img.PixelsEnPointsY(Hauteur)
    ObjFormulaire.Width = Img.PixelsEnPointsX(Largeur)
    ObjFormulaire.Repaint
    Call Opacité(0)
End If

' Efface les mémoires numéro 1, 2 et 3 qui vont être utilisées par la procédure:
Call EffaceImage(1): Call EffaceImage(2): Call EffaceImage(3)
 
' Création de 3 grandes mémoires pour y copier plusieurs lignes de texte:
Call CopieImage(1, 1, , , , , Largeur, 1000): Image(1).Transparence = -1
Call CopieImage(2, 2, , , , , Largeur, 1000): Image(2).Transparence = -1
Call CopieImage(3, 3, , , , , Largeur, 1000): Image(3).Transparence = -1
 
' Pose le titre dans un rectangle plein de la couleur de fond demandée, en mémoire 2:
Call RectanglePlein(Image(2).Hdc, 0, 0, Largeur, Police(PoliceTitre).Hauteur, CouleurFond)
Call Texte(Image(2).Hdc, (Largeur / 2), 0, Titre, PoliceTitre, AlignH_Centre)
 
' Trace un trait sous le titre, toujours en mémoire 2:
YY = Police(PoliceTitre).Hauteur
Call Trait(Image(2).Hdc, 0, YY, Largeur, YY, Police(PoliceTitre).CoulTexte, 1, Pensolide)

' Copie de la mémoire 2 (qui contient le titre souligné) en mémoire de travail 3:
Call CopieImage(2, 3)
 
' Dessine un rectangle plein en mémoire 1 pour faire un fond:
Call RectanglePlein(Image(1).Hdc, 0, 0, Largeur, 1000, CouleurFond)
 
' Pose en mémoire 1 les lignes du texte avec leur numéro de police:
For i = LBound(ListeTextes) To UBound(ListeTextes)
    Call Texte(Image(1).Hdc, 3, Taille, ListeTextes(i), Int(ListePolices(i)))
    Taille = Taille + Police(Int(ListePolices(i))).Hauteur
Next i
 
' Fait un double de l'image 1 à sa suite:
Call CopieImage(1, 1, 0, Taille, 0, 0, 0, Taille)
 
' Copie en mémoire 3 sous le titre, les lignes de texte sur la hauteur maximale:
Call CopieImage(1, 3, 0, YY + 1, 0, 0, Largeur, Hauteur)
Call RectangleVide(Image(3).Hdc, 0, 0, Largeur, Hauteur, Police(PoliceTitre).CoulTexte, 2)

On Error GoTo Fin ' Gestion de l'erreur si le formulaire est fermé.
' Boucle tant qu'une touche n'est pas pressée:
Do
For YY = 1 To Taille Step 2 ' Boucle pour décaler le texte en mémoire 1 à afficher.
    
    ' Copie l'image 2 (qui contient le titre souligné) dans l'image 3:
    Call CopieImage(2, 3)
    
    ' Copie l'image 1 (qui contient le texte) dans l'image 3, en décalant l'affichage:
    Call CopieImage(1, 3, 0, Police(PoliceTitre).Hauteur + 1, 0, YY, Largeur, Hauteur)
    
    ' Encadre l'affichage avec la couleur du titre si l'on n'est pas dans un formulaire:
    If ObjFormulaire Is Nothing Then _
    Call RectangleVide(Image(3).Hdc, 0, 0, Largeur, Hauteur, Police(PoliceTitre).CoulTexte, 2)
    
    ' Affiche en X,Y cette mémoire 3 (titre souligné + lignes de texte + encradrement):
    Call BitBlt(Hdc, X, Y, Largeur, Hauteur, Image(3).Hdc, 0, 0, SRCCOPY)
    Call Sleep(DuréePause) ' et fait une pause.
    If i > 0 Then
        i = 0  ' Au premier passage, fait un fondu en ouverture ou une attente d'une seconde
        If Not ObjFormulaire Is Nothing Then Call FonduOuverture(50) Else Call Sleep(1000)
    End If
    
    ' Quitte si une touche est enfoncée:
    If ToucheEnfoncée(0) = True Then Exit Do
    
    ' Bloque la souris dans l'espace du formulaire utilisé (erreur si formulaire fermé):
    If Not ObjFormulaire Is Nothing Then Call BloqueCurseurDansForm(ObjFormulaire)
    
Next YY
Loop

' Ferme le formulaire