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) :
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 SubLa 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.
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 SubLe 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 :
MoveToEx Hdc, X1, Y1, PointXY
LineTo Hdc, X2, Y1
LineTo Hdc, X2, Y2
LineTo Hdc, X1, Y2
LineTo Hdc, X1, Y1Pour 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.
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 SubPour é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.
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 SubNous 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.
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 SubRemarques 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 :
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 SubV. 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.
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 SubVI. 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.
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 SubVII. 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.
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 où 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 :
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 :
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 :
' 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 YAssimilez 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 :
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…
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 SubCertains 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 » :
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 LongExemples :
Call SetSystemCursor(LoadCursorFromFile("C:\WINDOWS\Cursors\aero_unavail.cur"), 32512) 
Call SetSystemCursor(LoadCursorFromFile("C:\WINDOWS\Cursors\aero_arrow.cur"), 32512) 
API pour masquer ou afficher la souris :
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As LongExemples :
Call ShowCursor(0) ' Masque le curseur de la souris
Call ShowCursor(1) ' Affiche le curseur de la sourisAPI pour mémoriser et déterminer l'espace de déplacement de la souris :
Declare Function GetClipCursor Lib "user32" (lprc As RECT) As Long
Declare Function ClipCursor Lib "user32" (lpRect As Any) As LongExemples :
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 :
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As LongExemple :
Dim PositionSouris as POINT
Call GetCursorPos(PositionSouris) ' Alimente PositionSouris.X et PositionSouris.YAPI pour savoir si une touche du clavier est enfoncée :
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As IntegerExemple :
Do
DoEvents
If GetKeyState(vbKeyDelete) < 0 Then Exit Do ' Sort si la touche Suppr est enfoncée.
LoopRetrouvez 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 :
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 :
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é :
Call PlaySound(ThisWorkbook.Path & "\laser-01.wav", pcsLOOP + pcsASYNC)Force la fin d'un son joué en boucle :
Call PlaySound(" ", pcsASYNC)Et pour faire parler votre ordinateur, en anglais :
'---------------------------------------------------------------------------------------
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 SubNotre 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.
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 SubRemarques 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.
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 :
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 :
' É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))'---------------------------------------------------------------------------------------
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 FunctionXI. 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).
'---------------------------------------------------------------------------------------
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 SubLa procédure peut être appelée pour dessiner un rectangle vide, en pointillés :
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) :
'---------------------------------------------------------------------------------------
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 SubPour obtenir le même résultat que précédemment, l'appel est simplifié en :
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 :
'---------------------------------------------------------------------------------------
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 SubL'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) :
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) :
'---------------------------------------------------------------------------------------
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 SubCe qui permet de dessiner un trait rouge en pointillé par cet appel :
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) :
'---------------------------------------------------------------------------------------
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 SubExemple d'appel pour dessiner un cercle bleu plein, de 130 pixels de diamètre, dont le centre est aux coordonnées 500, 500 :
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 :
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 EnumType personnalisé pour l'affichage des images :
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 TypeImageType personnalisé pour l'animation des avatars :
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 TypeAvatarEt 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 :
'---------------------------------------------------------------------------------------
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 SubInversement, la procédure FermeModeGraphique permet de libérer les mémoires utilisées par la gestion des images avant de quitter le mode graphique :
'---------------------------------------------------------------------------------------
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 SubLa 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.
'---------------------------------------------------------------------------------------
Public Sub EffaceImage(NumImage)
'---------------------------------------------------------------------------------------
DeleteObject SelectObject(Image(NumImage).Hdc, Image(NumImage).Obj)
DeleteDC Image(NumImage).Hdc
Image(NumImage).Hdc = 0
End SubLa 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 :
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.
'---------------------------------------------------------------------------------------
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 SubLa 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.
'---------------------------------------------------------------------------------------
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 SubLa 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.
'---------------------------------------------------------------------------------------
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 SubVous 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.
'---------------------------------------------------------------------------------------
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 SubLa 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.
'---------------------------------------------------------------------------------------
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 SubNous 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.
'---------------------------------------------------------------------------------------
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 SubIl 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…
'---------------------------------------------------------------------------------------
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 FunctionXIII. 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 :
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 LongL'instruction qui lance la procédure Descente toutes les 500 millièmes de seconde est :
TimerID = SetTimer(0, 0, 500, AddressOf Descente)À la fin de la boucle, l'événement est désactivé par l'instruction :
Call KillTimer(0, TimerID)Pour quitter l'animation en appuyant sur n'importe quelle touche, j'utilise l'instruction :
If Img.ToucheEnfoncée(0) = True Then Call Img.AfficheImage(0): Exit DoAprès avoir ajouté la fonction ToucheEnfoncée dans le module Img :
'---------------------------------------------------------------------------------------
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 FunctionVous 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.
'---------------------------------------------------------------------------------------
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 SubNous 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 : 
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.
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 :
|
|
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.
'---------------------------------------------------------------------------------------
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 SubXIV. 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 :
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.
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 LongLes 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.
Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As LongnIndex = LOGPIXELSX (88) pour la résolution horizontale et LOGPIXELSY (90) pour la résolution verticale.
'---------------------------------------------------------------------------------------
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 FunctionNous utiliserons aussi ces procédures pour bloquer la souris dans l'espace du formulaire :
'---------------------------------------------------------------------------------------
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 SubEt 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 :
'---------------------------------------------------------------------------------------
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 SubVoici donc la nouvelle version de la procédure d'initialisation du mode graphique :
'---------------------------------------------------------------------------------------
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 SubLa 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 :
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 SubLa 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.
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 LongLa 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.
'---------------------------------------------------------------------------------------
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 FunctionExemple pour passer en résolution WXGA 1280x800 et afficher un message en cas d'erreur :
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 IfNous 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 :
'---------------------------------------------------------------------------------------
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. |
|
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… |
|
|
Et le rendu que nous allons obtenir en mode graphique. |
|
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. |
|
|
31 : le mur. |
|
|
41 à 47 : le Sprite des pièces. |
|
|
51 à 62 : le Sprite du trooper. |
|
|
81 à 87 : le Sprite de l'explosion. |
|
|
98 : le fond d'écran d'origine où sera posé le plateau de jeu. |
|
|
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. |
|
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 :
Type TypeSerpent
X As Integer
Y As Integer
Forme As String * 1
End Type
Public Serpent(0 To 200) As TypeSerpentX 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 :
'---------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
CommandButton1.Visible = False ' Masque le bouton de lancement.
Call ImgSnake(Me) ' Lance l'animation dans le formulaire.
End SubJe 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.
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 : |
|
|
Ou bien dans une image, comme ici : |
|
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.
'---------------------------------------------------------------------------------------
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 si utilisation d'un formulaire:
If Not ObjFormulaire Is Nothing Then Call FonduFermeture(30): ObjFormulaire.Hide
Fin:
' Efface les mémoires numéro 1, 2 et 3:
Call EffaceImage(1): Call EffaceImage(2): Call EffaceImage(3)
' Restaure l'ancien espace souris, et l'ancien contexte actif:
Call ClipCursor(MémoSourisEspace)
Hdc = Anc_Hdc
End SubXVI. Compatibilité du module Img avec ACCESS▲
Le module Img permet de gérer vos animations soit directement à l'écran, pour simuler une animation sur une feuille de calcul, avec Hdc = GetWindowDC(0), soit dans un formulaire, après avoir retrouvé son contexte avec Hdc = GetDC(FindWindowA("ThunderDFrame", MonFormulaire.Caption)).
Suivant le but recherché, vous opterez pour l'une au l'autre méthode.
Le principe est comparable dans ACCESS, mais avec quelques particularités…
À commencer par le contexte d'un formulaire qui peut être retourné d'après les propriétés du formulaire, ce qui est plus simple : Hdc = GetWindowDC(Form_MonFormulaire.hwnd).
Les choses se compliquent concernant l'origine 0,0 du contexte du formulaire : alors que dans EXCEL l'origine est le point haut gauche à l'intérieur du formulaire, dans ACCESS l'origine est le point haut gauche du formulaire, incluant donc le bandeau supérieur contenant le libellé du formulaire.
Autre spécificité qui laisse penser que ce n'est pas la même équipe qui a développé ces deux applications, dans ACCESS les coordonnées d'un formulaire sont exprimées en Twips, qui valent 1/20e de point. Pour obtenir une équivalence en pixels avec nos procédures PointsEnPixels, il faudra diviser ces valeurs par 20, et les multiplier par 20 avec nos procédures PixelsEnPoints.
Gardez aussi à l'esprit que la configuration des options du formulaire est très importante et influencera l'affichage. Par exemple, si l'option « Fenêtre indépendante » est activée, alors le bandeau supérieur reste en premier plan et vos animations seront masquées par ce bandeau. Certaines options, telles que « Bouton de déplacement », « Afficher Sélecteur », empiètent sur l'intérieur du formulaire.
Optez pour le style de bordure « Double fixe » pour éviter que l'utilisateur modifie la taille du formulaire.
Voici un aperçu de ce que nous obtiendrons dans ACCESS :
Astuce à connaître pour ouvrir une application ACCESS à sa taille maximale, utilisez l'instruction : DoCmd.RunCommand acCmdAppMaximize
Les propriétés WindowLeft et WindowTop du formulaire indiquent ses coordonnées par rapport à l'intérieur de l'application. L'API GetWindowRect sera utilisée pour connaître les coordonnées, en pixels, du formulaire par rapport à l'origine 0,0 de l'écran :
Dim i As RECT
GetWindowRect Form_Menu.hwnd, iLa procédure InitialiseModeGraphique est adaptée pour pouvoir centrer un formulaire à l'écran suivant une marge horizontale ou verticale :
'---------------------------------------------------------------------------------------
Public Sub InitialiseModeGraphique(Optional ObjFormulaire As Object, _
Optional MargeH As Long = -1, Optional MargeV As Long = -1)
'---------------------------------------------------------------------------------------
Dim Irect As RECT
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
If MargeH > -1 Then ' S'il faut afficher le formulaire avec une marge horizontale:
ObjFormulaire.Move 0, ObjFormulaire.WindowTop, _
ObjFormulaire.WindowWidth, ObjFormulaire.WindowHeight
' Trouve la position X réelle du formulaire par rapport à l'écran:
Call GetWindowRect(ObjFormulaire.hWnd, Irect)
' Centre le formulaire à l'écran avec une marge horizontale:
ObjFormulaire.Move PixelsEnPointsX(MargeH - Irect.Left) * 20, ObjFormulaire.WindowTop, _
PixelsEnPointsX(GetSystemMetrics(0) - MargeH * 2) * 20, _
ObjFormulaire.WindowHeight
End If
If MargeV > -1 Then ' S'il faut afficher le formulaire avec une marge verticale:
ObjFormulaire.Move ObjFormulaire.WindowLeft, 0, _
ObjFormulaire.WindowWidth, ObjFormulaire.WindowHeight
' Trouve la position Y réelle du formulaire par rapport à l'écran:
Call GetWindowRect(ObjFormulaire.hWnd, Irect)
' Centre le formulaire avec une marge verticale:
ObjFormulaire.Move ObjFormulaire.WindowLeft, PixelsEnPointsY(MargeV - Irect.Top) * 20, _
ObjFormulaire.WindowWidth, PixelsEnPointsY(GetSystemMetrics(1) - MargeV * 2) * 20
End If
' Mémorise les dimensions maximales du formulaire (en pixels):
ImageMaxiX = PointsEnPixelsX(ObjFormulaire.WindowWidth) / 20 ' Taille horizontale.
ImageMaxiY = PointsEnPixelsY(ObjFormulaire.WindowHeight) / 20 ' Taille verticale.
ObjFormulaire.Repaint
' Mémorise le contexte du formulaire:
Hdc = GetWindowDC(ObjFormulaire.hWnd)
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 SubIl faut aussi modifier les procédures utilisées par le module Img pour bloquer la souris dans le formulaire et inversement pour lire la position de la souris :
'---------------------------------------------------------------------------------------
Public Sub BloqueCurseurDansForm(ObjFormulaire As Object)
'---------------------------------------------------------------------------------------
Call GetWindowRect(ObjFormulaire.hwnd, SourisBloque)
Hdc = GetWindowDC(ObjFormulaire.hwnd)
End SubDans ACCESS, le contexte Hdc change en cas de déplacement du formulaire, il faut donc le recalculer en permanence au cas où. Cela peut se faire ici, de façon transparente pour le programmeur.
'---------------------------------------------------------------------------------------
Public Sub LectureCurseurDansForm(Pt As POINT, ObjFormulaire As Object)
'---------------------------------------------------------------------------------------
Dim Irect As RECT
Call GetCursorPos(Pt)
Call GetWindowRect(ObjFormulaire.hwnd, Irect)
Pt.X = Pt.X - Irect.Left
Pt.Y = Pt.Y - Irect.Top
End SubNous pouvons récupérer le code du tir au canard dans une application ACCESS. Attention, certaines instructions du VBA EXCEL ne sont pas compatibles avec ACCESS. Dans notre code, il faut remplacer l'instruction ActiveWorkbook.Path par CurrentProject.Path.
Dernier point, la gestion du clic de la souris. Qui une fois de plus pose problème, car le clic sur le formulaire donne la main au formulaire et n'est pas reconnu par notre code.
Pour contourner cette situation, j'ai ajouté la variable publique BoutonSouris, qui est alimentée à 1 lors d'un clic sur le formulaire, par l'événement « Sur clic » du détail :
'---------------------------------------------------------------------------------------
Private Sub Détail_Click()
BoutonSouris = 1 ' Indique que le bouton gauche de la souris est actionné
End SubLa lecture du clic gauche de la souris, If Img.ToucheEnfoncée(vbKeyLButton) = True Then devient If BoutonSouris = 1 Then.
La variable BoutonSouris est remise à zéro si elle vaut un, pour éviter une lecture en boucle.
Enfin, dernière particularité ACCESS, le bouton de commande du formulaire qui lance le jeu ne peut pas être masqué car il est actif. Pour le rendre non visible, on peut toutefois mettre ses dimensions à zéro :
'---------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
CommandButton1.Height = 0 ' Supprime la hauteur du bouton
CommandButton1.Width = 0 ' Supprime la largeur du bouton
Call ImgDansUnFormulaire(Me) ' Lance l'animation dans le formulaire.
End SubLe reste du code est inchangé.
Le module Img développé pour EXCEL est donc, presque, compatible avec ACCESS. Mais il nous faut maintenir deux versions différentes, ce qui n'est pas pratique.
Heureusement, il existe la compilation conditionnelle.
XVII. La compilation conditionnelle▲
La compilation conditionnelle permet au VBA de compiler des blocs de code sélectivement. Dit autrement, il est possible de compiler ou non un bloc de code suivant une condition prédéfinie.
La compilation conditionnelle s'applique donc parfaitement à notre situation où un même module doit être utilisé dans EXCEL et dans ACCESS alors que certains blocs de codes sont incompatibles.
Concrètement, nous allons définir, en entête du module Img, une « constante de compilation conditionnelle ». Par exemple :
#Const MonAppli = "Excel" ' Mettre "Excel" pour EXCEL et "Access" pour ACCESSLes constantes de compilation conditionnelle sont reconnaissables par le dièse qui les précède.
Le nom des variables est libre, mais préférez des noms évocateurs.
Les blocs de code devant être compilés suivant la valeur de MonAppli sont définis d'après les « consignes » de compilation : #If...Then ... #Else ... #ElseIf ... #End If.
Ici, la procédure BloqueCurseurDansForm du module Img utilise la constante de compilation conditionnelle MonAppli pour déterminer les blocs de code à compiler, et ainsi ignorer le code ne correspondant pas notre application hôte.
MonAppli sera déclarée avec la valeur Excel, quand le module Img sera utilisé dans EXCEL, et avec la valeur Access quand elle sera utilisée dans ACCESS :
'---------------------------------------------------------------------------------------
Public Sub BloqueCurseurDansForm(ObjFormulaire As Object)
'---------------------------------------------------------------------------------------
#If MonAppli = "Excel" Then
SourisBloque.Top = PointsEnPixelsX(ObjFormulaire.Top)
SourisBloque.Left = PointsEnPixelsY(ObjFormulaire.Left)
SourisBloque.Bottom = PointsEnPixelsY(ObjFormulaire.Top + ObjFormulaire.Height)
SourisBloque.Right = PointsEnPixelsX(ObjFormulaire.Left + ObjFormulaire.Width)
#End If
#If MonAppli = "Access" Then
Call GetWindowRect(ObjFormulaire.hWnd, SourisBloque)
Hdc = GetWindowDC(ObjFormulaire.hWnd)
#End If
Call ClipCursor(SourisBloque)
End SubIl devient aisé maintenant de développer un module Img entièrement compatible EXCEL - ACCESS pour la programmation en mode graphique.
XVIII. Un outil pour définir la couleur de transparence des images▲
Nous l'avons vu avec Snake, un jeu en mode graphique nécessite de nombreuses images pour les animations. Et pour un meilleur rendu, ces images sont affichées avec un fond transparent. Or les images que l'on déniche sur le web pour les réutiliser dans nos jeux sont souvent composées de dégradés de centaines de couleurs et non pas d'une couleur de fond unique. Pour définir une couleur de transparence, il faut alors recourir à des logiciels de retouche d'image, qui ne sont pas toujours adaptés à notre besoin. Par exemple, si l'outil « Remplissage » de Paint permet de colorier rapidement une portion de l'image, cela n'a d'effet que sur les pixels contigus de même couleur. Impossible donc de se servir de cette fonction sur un fond en dégradé. Sauf à y passer beaucoup de temps, où à convertir l'image en 256 couleurs, ce qui peut nuire au rendu final.
|
La méduse représentée ici est placée devant un fond dégradé noir et bleu composé de plusieurs milliers de couleurs. Pour comprendre comment unifier ce fond, il faut revenir sur la notion de couleur en informatique. |
|
Chaque couleur est constituée d'un indice rouge, vert, bleu compris entre 0 et 255, l'équivalent de nos couleurs primaires en peinture.
Cela permet de représenter une palette de 16 777 216 couleurs, allant du noir (0, 0, 0) au blanc (255, 255, 255).
Le numéro d'une couleur est obtenu par la formule : rouge + (vert x 256) + (bleu x 256²).
Inversement chaque indice peut être retrouvé d'après le numéro d'une couleur par la formule : rouge = Int(Couleur Mod 256) ; vert = Int((Couleur Mod 65536) / 256) ; bleu = Int(Couleur / 65536).
Ainsi la couleur 525 571 (3, 5, 8) est très proche de la couleur 0 (0, 0, 0) car leurs indices sont proches. Ce n'est pas intuitif lorsque l'on compare l'écart entre leurs numéros de couleur. C'est plus causant en exprimant la couleur 525 571 en pourcentage : elle est composée de 1,18 % de rouge, 1,96 % de vert, 3,14 % de bleu. Pour l'œil humain cela ressemble bigrement à du noir.
Inversement, la couleur 255 (255, 0, 0) est un rouge vif, très différent du noir (0, 0, 0) numéro 0.
|
Sachant cela, unifier avec une couleur de son choix le fond dégradé de cette image devient un jeu d'enfant : il suffit d'analyser la couleur de chaque pixel de l'image, et de l'échanger si l'écart entre ses 3 indices et les 3 indices de la couleur de référence est faible, par exemple de 10 points. En quelques manipulations vous obtenez ceci : |
|
J'ai développé sous EXCEL un outil basé sur ces principes, destiné aux images de taille réduite utilisées par nos animations.
Deux formulaires sont mis à contribution : le premier contient l'image à modifier, sélectionnée par une boîte de dialogue (voir le module VBO du tome 1). Sa taille est adaptée aux dimensions de l'image pour éviter de la déformer. Attention, une image trop grande risque d'avoir ses couleurs détériorées.
Le second formulaire affiche un zoom de l'image suite à un clic sur l'image du formulaire principal.
Dans la partie gauche du classeur sont affichées des informations sur les couleurs de l'image : numéro de la couleur, rendu de la couleur, nombre de pixels de cette couleur. Seules 10 000 lignes sont affichées pour des problèmes de capacité d'EXCEL.
Volontairement, la souris n'est pas bornée aux limites du formulaire principal, ce qui permet de se déplacer sur le classeur et dans le formulaire du zoom. La couleur pointée par la souris, n'importe où à l'écran, est indiquée dans le libellé des formulaires.
Le classeur est protégé pour éviter qu'il ne soit sélectionné et ainsi faire perdre la main au VBA, mais l'ascenseur reste actif et permet de consulter les informations sur les couleurs de l'image.
La touche « M » mémorise la couleur pointée par la souris. L'information est reportée en ligne 1 du classeur.
La touche « E » échange la couleur pointée par la souris ainsi que ses couleurs proches, par la couleur mémorisée, suivant la marge de tolérance désirée. La touche « + » augmente cette marge (maximum = 50) et la touche « - » la diminue (minimum = 0).
Les touches « 0 » à « 5 » affectent directement une valeur pour cette marge, de 0 à 50.
La touche « R » effectue un remplissage de la couleur pointée par la souris ainsi que ses couleurs proches, par la couleur mémorisée, suivant la marge de tolérance désirée.
La combinaison « Ctrl Z » annule la dernière modification faite.
La combinaison « Ctrl S » sauvegarde l'image modifiée dans un fichier BMP. Le nom du fichier est le nom du fichier source suivi de « _BMP.bmp », puis fait quitter EXCEL.
La touche « Fin » quitte EXCEL.
La procédure utilisée, CopieEnBMP, permet de sauvegarder en fichier BMP une image mémorisée ou un formulaire. Cette procédure est compatible EXCEL - ACCESS :
'---------------------------------------------------------------------------------------
Public Sub CopieEnBMP(Optional StrNomDuFichier As String, Optional ByVal ObjFormulaire As Object, _
Optional ImgSource As Integer = -9)
'---------------------------------------------------------------------------------------
' StrNomDuFichier : Nom du fichier généré ou "CopieEnBMP" si non renseigné
' et si l'extension .BMP n'est pas mise alors la rajoute.
' ObjFormulaire : Nom du formulaire s'il faut copier le formulaire et pas une image.
' ImgSource : Numéro de l'image à copier.
'---------------------------------------------------------------------------------------
Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
Dim Irect As RECT
Dim lngLargeur As Long, lngHauteur As Long
Dim lngHdc As Long
Dim lngHBmp As Long
Dim bmiBitmapInfo As BitmapInfo
Dim bmfBitmapFileHeader As BitMapFileHeader
Dim lngFnum As Integer
Dim pixels() As Byte
Dim bolOuvert As Boolean
Dim StrFichier As String
' S'il faut copier le formulaire:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Not ObjFormulaire Is Nothing Then
#If MonAppli = "Excel" Then
X1 = X1 + PointsEnPixelsX(ObjFormulaire.Left)
Y1 = Y1 + PointsEnPixelsY(ObjFormulaire.Top)
X2 = X1 + PointsEnPixelsX(ObjFormulaire.Width)
Y2 = Y1 + PointsEnPixelsY(ObjFormulaire.Height)
#End If
#If MonAppli = "Access" Then
Call GetWindowRect(ObjFormulaire.hWnd, Irect)
X1 = Irect.Left
Y1 = Irect.Top
X2 = Irect.Right
Y2 = Irect.Bottom
#End If
End If
lngHauteur = Y2 - Y1
lngLargeur = X2 - X1
If ImgSource <> -9 Then
lngHauteur = Image(ImgSource).Hauteur
lngLargeur = Image(ImgSource).Largeur
End If
' Crée un bitmap vierge:
' ~~~~~~~~~~~~~~~~~~~~~~
With bmiBitmapInfo
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bmiBitmapInfo)
.biHeight = lngHauteur
.biWidth = lngLargeur
.biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
lngHdc = CreateCompatibleDC(0)
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
Call SelectObject(lngHdc, lngHBmp)
' Copie la partie de l'écran demandée:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ImgSource = -9 Then
Call BitBlt(lngHdc, 0, 0, lngLargeur, lngHauteur, GetDC(GetDesktopWindow()), X1, Y1, SRCCOPY)
Else
Call BitBlt(lngHdc, 0, 0, lngLargeur, lngHauteur, Image(ImgSource).Hdc, 0, 0, SRCCOPY)
End If
' Crée l'entête du fichier bmp:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With bmfBitmapFileHeader
.bfType = &H4D42&
.bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
.bfSize = .bfOffBits + bmiBitmapInfo.biSizeImage
End With
' Lit les bits du bitmap et les place dans le tableau de pixels:
ReDim pixels(1 To 4, 1 To lngLargeur, 1 To lngHauteur)
Call GetDIBits(lngHdc, lngHBmp, 0, lngHauteur, pixels(1, 1, 1), bmiBitmapInfo, DIB_RGB_COLORS)
' Demande un numéro temporaire de fichier:
lngFnum = FreeFile
' Supprime le fichier s'il existe:
StrFichier = StrNomDuFichier
If StrFichier = "" Then StrFichier = "CopieEnBMP" ' nom du fichier par défaut si non renseigné
If InStr(1, StrFichier, ".") = 0 Then StrFichier = StrFichier & ".BMP" ' ajoute l'extension .BMP si besoin
#If MonAppli = "Excel" Then
If InStr(1, StrFichier, ":") = 0 Then StrFichier = ThisWorkbook.Path & "\" & StrFichier ' répertoire du projet si chemin non renseigné.
#End If
#If MonAppli = "Access" Then
If InStr(1, StrFichier, ":") = 0 Then StrFichier = CurrentProject.Path & "\" & StrFichier ' répertoire du projet si chemin non renseigné.
#End If
On Error Resume Next
Kill StrFichier
' Crée le fichier:
Open StrFichier For Binary As lngFnum
bolOuvert = True
' Écrit l'entête:
Put #lngFnum, , bmfBitmapFileHeader
' Écrit les informations du bitmap:
Put #lngFnum, , bmiBitmapInfo
' Écrit les bits de l'image:
Put #lngFnum, , pixels
' Ferme le fichier si ouvert:
If bolOuvert Then Close lngFnum
' Supprime les objets:
If lngHBmp <> 0 Then DeleteObject lngHBmp
If lngHdc <> 0 Then DeleteDC lngHdc
End SubLe code de cette application, lancée depuis le bouton CommandButton1 d'un formulaire :
'---------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'---------------------------------------------------------------------------------------
CommandButton1.Visible = False ' Masque le bouton de lancement.
Call Main(Me) ' Lance l'animation dans le formulaire.
End SubOption Explicit
Dim i As Long, TabDonnées() As Variant, Quantité() As Long, MAJ_Zoom As Boolean
Dim C0 As Long, ZoomHdc As Long, ZoomMaxiX As Long, ZoomMaxiY As Long, Marge As Long
Dim MiniX As Long, MiniY As Long, MaxiX As Long, MaxiY As Long
Dim PixelTraité() As Byte, InfoAction As Boolean, Nb As Byte
'-------------------------------------------------------------------------------------------
Public Sub Main(MyForm As Object)
'-------------------------------------------------------------------------------------------
Dim x As Long, Y As Long, C As Long, HtImage As Long, LgImage As Long, Coef As Double
Dim MonFichier As String, Zm As POINT
' Pioche le fichier image à traiter:
MonFichier = VBO.BoiteDialogue(msoFileDialogFilePicker, "Choix image", "", "", "", "Image,*.Bmp;*.Jpg")
'MonFichier = ThisWorkbook.Path & "\Sprite_Superman.bmp"
'MonFichier = ThisWorkbook.Path & "\Sprite_Stormtrooper.bmp"
If MonFichier = "" Then Exit Sub
' Initialisation du mode graphique et chargement de l'image source en mémoire 99:
Call Img.InitialiseModeGraphique(MyForm)
Call Img.ChargeImageBMP(MonFichier, 99, -1)
' Calcule la taille du formulaire pour contenir l'image sans trop la déformer:
HtImage = Image(99).Hauteur
LgImage = Image(99).Largeur
Coef = 1
While LgImage > GetSystemMetrics(0) * 0.9 Or HtImage > GetSystemMetrics(1) * 0.9
Coef = Coef - 0.01
LgImage = Image(99).Largeur * Coef
HtImage = Image(99).Hauteur * Coef
Wend
While LgImage < GetSystemMetrics(0) * 0.3 And HtImage < GetSystemMetrics(1) * 0.3
Coef = Coef + 0.01
LgImage = Image(99).Largeur * Coef
HtImage = Image(99).Hauteur * Coef
Wend
MyForm.Width = Img.PixelsEnPointsX(LgImage + 5)
MyForm.Height = Img.PixelsEnPointsY(HtImage + 25)
' Centre le formulaire à l'écran:
MyForm.Left = Img.PixelsEnPointsX(GetSystemMetrics(0) / 2) - (MyForm.Width / 2)
MyForm.Top = Img.PixelsEnPointsY(GetSystemMetrics(1) / 2) - (MyForm.Height / 2)
' Mémorise les dimensions du formulaire:
ImageMaxiX = Img.PointsEnPixelsX(MyForm.InsideWidth)
ImageMaxiY = Img.PointsEnPixelsY(MyForm.InsideHeight)
' Création d'une mémoire 10 correspondant à l'image source 99 de la taille du formulaire:
Call Img.ModifieTailleImage(99, ImageMaxiX, ImageMaxiY, 10)
Call Img.AfficheImage(10)
' Recherche les différentes couleurs de la palette:
MyForm.Caption = "Analyse en cours..."
Application.Cursor = xlWait
Application.ScreenUpdating = False
i = 0
For Y = 0 To Image(10).Hauteur - 1
For x = 0 To Image(10).Largeur - 1
C = GetPixel(Image(10).Hdc, x, Y)
ReDim Preserve TabDonnées(i)
TabDonnées(i) = C
i = i + 1
Next x
Next Y
' Trie les couleurs sans doublon:
Call VBO.QuickRanking(TabDonnées, True, 4)
' Affiche la palette:
Y = 2
For i = 0 To UBound(TabDonnées)
Cells(Y, 1) = i
Cells(Y, 2) = TabDonnées(i)
Cells(Y, 3).Interior.Color = TabDonnées(i)
Y = Y + 1: If Y > 10000 Then Exit For ' Limite à 10000 lignes
If Y Mod 17 = 0 Then MyForm.Caption = "Palette : " & Format(i / UBound(TabDonnées) * 100, "0") & "%"
Next i
' Affiche le nombre de pixels par couleur:
Call ComptePixelParCouleur
' Affiche le formulaire Zoom:
Call User_Zoom.Show(False)
User_Zoom.Left = 0
User_Zoom.Top = 0
ZoomHdc = GetDC(FindWindowA("ThunderDFrame", User_Zoom.Caption))
ZoomMaxiX = Img.PointsEnPixelsX(User_Zoom.InsideWidth)
ZoomMaxiY = Img.PointsEnPixelsY(User_Zoom.InsideHeight)
Zm.x = ZoomMaxiX / 8
Zm.Y = ZoomMaxiY / 8
MAJ_Zoom = True
' Charge l'image du curseur de la souris, image 21, depuis le formulaire User_Image:
Call Img.ChargeImageFormulaire(User_Images, "Image1", 21, -9)
Call Img.ModifieTailleImage(21, 32, 32)
' Création des différentes images:
Call Img.CopieImage(11, 11, 0, 0, 0, 0, ZoomMaxiX / 4, ZoomMaxiY / 4) ' 11 = Image du zoom
Call Img.CopieImage(12, 12, 0, 0, 0, 0, ZoomMaxiX, ZoomMaxiY) ' 12 = Partie pointée
Call Img.CopieImage(10, 13) ' 13 = Annulation
Marge = 10
On Error GoTo Fin ' Gestion de l'erreur si le formulaire est fermé.
Do
' Affiche l'image 10 en cas de bug de l'écran:
Call Img.AfficheImage(10)
' Recherche la couleur pointée par la souris à l'écran et pas que dans le formulaire:
Call GetCursorPos(Pt)
C = GetPixel(GetWindowDC(0), Pt.x, Pt.Y)
MyForm.Caption = "Marge : " & Marge & " // Couleur pointée : " & C
User_Zoom.Caption = "Marge : " & Marge & " // Couleur pointée : " & C
' Lecture du clic gauche de la souris:
If Img.ToucheEnfoncée(vbKeyLButton) = True Then
Call Img.LectureCurseurDansForm(Pt, MyForm)
' Si le curseur est dans le formulaire alors lance le zoom:
If Pt.x > 0 And Pt.Y > 0 _
And Pt.x < Img.PointsEnPixelsX(MyForm.Width) _
And Pt.Y < Img.PointsEnPixelsY(MyForm.Height) Then
Zm.x = Pt.x - 2 ' Correction de la marge gauche du formulaire.
Zm.Y = Pt.Y - 25 ' Correction de la marge haute du formulaire.
MAJ_Zoom = True ' Active la mise à jour du zoom.
End If
End If
' Afficher le zoom de la partie pointée:
If MAJ_Zoom = True Then
' Force l'affichage du formulaire Zoom au cas où il a été fermé:
Call User_Zoom.Show(False)
ZoomHdc = GetDC(FindWindowA("ThunderDFrame", User_Zoom.Caption))
' Copie la partie pointée en mémoire 11 (taille de l'image 11 = taille du formulaire zoom / 4):
Call Img.CopieImage(10, 11, 0, 0, Zm.x - (Image(11).Largeur / 2), _
Zm.Y - (Image(11).Hauteur / 2), ZoomMaxiX, ZoomMaxiY)
' Agrandie cette image = zoom (taille de l'image 12 = taille du formulaire zoom):
Call Img.ModifieTailleImage(11, Image(12).Largeur, Image(12).Hauteur, 12)
' Pose le curseur de la souris:
Call Img.CopieImage(21, 12, ZoomMaxiX / 2, ZoomMaxiY / 2)
' Affiche l'image 12 dans le formulaire zoom:
Call BitBlt(ZoomHdc, 0, 0, Image(12).Largeur, Image(12).Hauteur, Image(12).Hdc, 0, 0, SRCCOPY)
MAJ_Zoom = False
End If
' Lecture de M (mémorise la couleur qui sera utilisée pour échanger les couleurs):
If Img.ToucheEnfoncée(vbKeyM) = True Then C0 = C: Call ComptePixelParCouleur
' Lecture de E (Echange la couleur pointée):
If Img.ToucheEnfoncée(vbKeyE) = True Then
Call Img.CopieImage(10, 13) ' Image avant modification.
Call RemplaceCouleur(C, Marge) ' Modifie l'image
Call ComptePixelParCouleur ' Compte le nombre de pixels par couleur.
End If
' Lecture de R (Remplissage):
If Img.ToucheEnfoncée(vbKeyR) = True Then
' Si le curseur est dans le formulaire:
Call Img.LectureCurseurDansForm(Pt, MyForm)
If Pt.x > 0 And Pt.Y > 0 _
And Pt.x < Img.PointsEnPixelsX(MyForm.Width) _
And Pt.Y < Img.PointsEnPixelsY(MyForm.Height) Then
Zm.x = Pt.x - 2 ' Pixel pointé par la souris.
Zm.Y = Pt.Y - 25 ' Pixel pointé par la souris.
Call Img.CopieImage(10, 13) ' Image avant modification.
Call RemplissageCouleur(Zm.x, Zm.Y, C, Marge) ' Modifie l'image.
Call ComptePixelParCouleur
MAJ_Zoom = True
End If
End If
' Lecture de la touche "+" pour augmenter la marge:
If Img.ToucheEnfoncée(vbKeyAdd) = True Then
Marge = Marge + 1: Call Sleep(80): If Marge > 50 Then Marge = 50
End If
' Lecture de la touche "-" pour diminuer la marge:
If Img.ToucheEnfoncée(vbKeySubtract) = True Then
Marge = Marge - 1: Call Sleep(80): If Marge < 0 Then Marge = 0
End If
' Lecture des touches "0" "1" "2" "3" "4" "5" pour ajuster la marge:
If Img.ToucheEnfoncée(vbKeyNumpad0) = True Then Marge = 0
If Img.ToucheEnfoncée(vbKeyNumpad1) = True Then Marge = 10
If Img.ToucheEnfoncée(vbKeyNumpad2) = True Then Marge = 20
If Img.ToucheEnfoncée(vbKeyNumpad3) = True Then Marge = 30
If Img.ToucheEnfoncée(vbKeyNumpad4) = True Then Marge = 40
If Img.ToucheEnfoncée(vbKeyNumpad5) = True Then Marge = 50
' Lecture de Ctrl Z (annulation de la dernière commande):
If Img.ToucheEnfoncée(vbKeyControl) = True And Img.ToucheEnfoncée(vbKeyZ) = True Then
Call Img.CopieImage(13, 10)
MAJ_Zoom = True
End If
' Lecture de Ctrl S (sauvegarde l'image 10 après lui avoir remis la taille d'origine et quitte):
If Img.ToucheEnfoncée(vbKeyControl) = True And Img.ToucheEnfoncée(vbKeyS) = True Then
Call Img.ModifieTailleImage(10, Image(99).Largeur, Image(99).Hauteur, 10)
' Nom du fichier généré = nom du fichier source + _BMP
MonFichier = Left(MonFichier, InStrRev(MonFichier, ".") - 1) & "_BMP.bmp"
Call Img.CopieEnBMP(MonFichier, , 10)
GoTo Fin
End If
Loop While Img.ToucheEnfoncée(vbKeyEnd) = False
Fin:
' Ferme le mode graphique et quitte EXCEL:
Call Img.FermeModeGraphique
Application.DisplayAlerts = False
Application.Quit
End Sub
'-------------------------------------------------------------------------------------------
Sub ComptePixelParCouleur()
'-------------------------------------------------------------------------------------------
Dim x As Long, Y As Long, Coul As Long, lk As Long
Dim Trouvé As Boolean
ReDim Quantité(0 To UBound(TabDonnées))
' Ôte la protection de la feuille:
Sheets("Info").Unprotect
Sheets("Info").EnableSelection = xlNoSelection
' Compte le nombre de pixels par couleur:
Application.Cursor = xlWait
Application.ScreenUpdating = False
For Y = 0 To Image(10).Hauteur - 1
User_Img.Caption = "Compte les pixels : " & Format(Y / Image(10).Hauteur * 100, "0") & "%"
For x = 0 To Image(10).Largeur - 1
Coul = GetPixel(Image(10).Hdc, x, Y)
lk = VBO.RechercheDichotomique(TabDonnées(), Coul, True, Trouvé)
If Trouvé = True Then Quantité(lk) = Quantité(lk) + 1
Next x
Next Y
' Affiche le résultat trouvé et masque la ligne si la quantité est 0:
Y = 2
For i = 0 To UBound(TabDonnées)
If Quantité(i) > 0 Then Cells(Y, 4) = Quantité(i) Else Rows(Y).RowHeight = 0
Quantité(i) = 0
Y = Y + 1: If Y > 10000 Then Exit For ' Limite à 10000 lignes
Next i
' Informations sur la couleur mémorisée:
Range("Couleur_mémorisée").Interior.Color = C0
Range("Numéro_Couleur") = C0
Range("Rouge") = Int(C0 Mod 256)
Range("Vert") = Int((C0 Mod 65536) / 256)
Range("Bleu") = Int(C0 / 65536)
' Fin de l'analyse:
Application.ScreenUpdating = True
Application.Cursor = xlDefault
' Remet la protection de la feuille pour éviter sa sélection et donc désactiver le formulaire:
Sheets("Info").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Sheets("Info").EnableSelection = xlNoSelection
End Sub
'-------------------------------------------------------------------------------------------
Sub RemplaceCouleur(C As Long, Marge As Long)
'-------------------------------------------------------------------------------------------
' Boucle sur les tous les pixels de l'image 10 et les analyse avec TraitementPixel.
'-------------------------------------------------------------------------------------------
Dim x As Long, Y As Long
Application.Cursor = xlWait
For Y = 0 To Image(10).Hauteur - 1
User_Img.Caption = "Remplace par " & C0 & " : " & Format(Y / Image(10).Hauteur * 100, "0") & "%"
For x = 0 To Image(10).Largeur - 1
Call TraitementPixel(x, Y, C, Marge)
Next x
Next Y
' Fin du traitement:
Application.Cursor = xlDefault
MAJ_Zoom = True
End Sub
'-------------------------------------------------------------------------------------------
Function TraitementPixel(x As Long, Y As Long, C As Long, Marge As Long, _
Optional MAJPixel As Boolean = True) As Boolean
'-------------------------------------------------------------------------------------------
' Analyse le pixel X,Y pour éventuellement changer sa couleur en C0, si l'écart entre ses
' indices et les indices de la couleur de référence est conforme à la marge admise.
'-------------------------------------------------------------------------------------------
Dim C_Rouge As Integer, C_Vert As Integer, C_Bleu As Integer
Dim Cl As Long, Cl_Rouge As Integer, Cl_Vert As Integer, Cl_Bleu As Integer
' Si même couleur alors indique que le traitement est ok et quitte:
Cl = GetPixel(Image(10).Hdc, x, Y)
If Cl = C0 Then TraitementPixel = True: Exit Function
' Indice de la couleur du pixel analysé:
Cl_Rouge = Int(Cl Mod 256)
Cl_Vert = Int((Cl Mod 65536) / 256)
Cl_Bleu = Int(Cl / 65536)
' Indice de la couleur à remplacer:
C_Rouge = Int(C Mod 256)
C_Vert = Int((C Mod 65536) / 256)
C_Bleu = Int(C / 65536)
' Si l'écart des indices est dans la marge alors fait l'échange avec la couleur C0:
If Abs(C_Rouge - Cl_Rouge) <= Marge And Abs(C_Vert - Cl_Vert) <= Marge _
And Abs(C_Bleu - Cl_Bleu) <= Marge Then
If MAJPixel = True Then Call SetPixel(Image(10).Hdc, x, Y, C0)
TraitementPixel = True
End If
End FunctionPour réaliser le remplissage d'une portion de l'image, comme le fait Paint, mais ici avec une marge de tolérance dans les indices des couleurs, j'ai testé plusieurs méthodes, et je me suis cassé le nez à plusieurs reprises. Avant d'imaginer la procédure qui suit. Son principe : boucler sur les pixels de l'image et mémoriser leur « état » dans une matrice PixelTraité. S'ils sont potentiellement échangeables, le code 11 leur est attribué. Au point d'origine, j'attribue le code 12. Il reste à boucler sur cette matrice, et comparer chaque pixel de code 11 avec ses 8 pixels adjacents. Si l'un d'eux vaut 12, alors le code du pixel analysé passe à 12. Le traitement se termine quand plus aucune modification n'est faite. Sinon la boucle reprend depuis le début de la matrice.
Pour accélérer les traitements, lorsqu'un pixel à ses 8 pixels adjacents d'un code différent de 11, alors il passe à la valeur 13. Ceci permet d'éviter les analyses inutiles. Inutile aussi de poursuivre l'analyse d'une ligne si tous les pixels suivants ont un code différent de 11.
'-------------------------------------------------------------------------------------------
Function InfoPixelContigue(x As Long, Y As Long, h As Long, V As Long) As Byte
'-------------------------------------------------------------------------------------------
' Si le pixel peut être échangé alors il est contigu:
If PixelTraité(x + h, Y + V) = 11 Then
InfoPixelContigue = True
PixelTraité(x + h, Y + V) = 12
If x + h < MiniX Then MiniX = x + h
If Y + V < MiniY Then MiniY = Y + V
Call SetPixel(Image(10).Hdc, x + h, Y + V, C0)
End If
' S'il a été échangé ou est non échangeable, il est quand même traité:
If PixelTraité(x + h, Y + V) <> 11 Then Nb = Nb + 1
End Function
'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------
Sub RemplissageCouleur(Xi As Long, Yi As Long, C As Long, Marge As Long)
'-------------------------------------------------------------------------------------------
' Échange la couleur des pixels adjacents au point Xi,Yi, suivant la marge admise.
'-------------------------------------------------------------------------------------------
Dim x As Long, Y As Long, NbDejàTraité As Long
Dim XX As Long, YY As Long
' Création d'un tableau matrice qui contient la situation des pixels de l'image:
ReDim PixelTraité(-1 To Image(10).Largeur + 1, -1 To Image(10).Hauteur + 1)
Application.Cursor = xlWait
' Boucle sur tous les pixels pour savoir s'il faudra éventuellement les échanger ou non:
MaxiX = 0
For Y = 0 To Image(10).Hauteur - 1
NbDejàTraité = 0
For x = 0 To Image(10).Largeur - 1
If TraitementPixel(x, Y, C, Marge, False) = True Then
PixelTraité(x, Y) = 11 ' Code 11 dans la matrice si un pixel peut être changé.
MaxiY = Y
If x > MaxiX Then MaxiX = x
End If
NbDejàTraité = IIf(PixelTraité(x, Y) <> 11, NbDejàTraité + 1, 0)
Next x
PixelTraité(x - NbDejàTraité, Y) = 1 ' Code 1 pour la fin du traitement de la ligne.
Next Y
' Échange le pixel pointé par la souris = point d'origine du traitement:
MiniX = Xi: MiniY = Yi
PixelTraité(Xi, Yi) = 12 ' Code 12 dans la matrice si un pixel a été changé.
Call SetPixel(Image(10).Hdc, Xi, Yi, C0)
' Boucle sur tous les pixels de l'image pour changer les pixels contigus:
Do
InfoAction = False
For Y = MiniY To MaxiY
NbDejàTraité = 0
For x = MiniX To MaxiX
' Compte le nombre de pixels déjà traités sur la ligne pour ne plus les analyser:
NbDejàTraité = IIf(PixelTraité(x, Y) <> 11, NbDejàTraité + 1, 0)
' Si code 1 alors fin du traitement de la ligne:
If PixelTraité(x, Y) = 1 Then x = x + 1: Exit For
' Si code 12 alors analyse les pixels adjacents:
If PixelTraité(x, Y) = 12 Then
Nb = 0
If InfoPixelContigue(x, Y, -1, -1) = True Then InfoAction = True
If InfoPixelContigue(x, Y, 0, -1) = True Then InfoAction = True
If InfoPixelContigue(x, Y, 1, -1) = True Then InfoAction = True
If InfoPixelContigue(x, Y, -1, 0) = True Then InfoAction = True
If InfoPixelContigue(x, Y, 1, 0) = True Then InfoAction = True
If InfoPixelContigue(x, Y, -1, 1) = True Then InfoAction = True
If InfoPixelContigue(x, Y, 0, 1) = True Then InfoAction = True
If InfoPixelContigue(x, Y, 1, 1) = True Then InfoAction = True
If Nb = 8 Then PixelTraité(x, Y) = 13 ' Code 13 si tous les adjacents sont traités.
End If
Next x
PixelTraité(x - NbDejàTraité, Y) = 1 ' Code 1 pour indiquer la fin du traitement de la ligne.
Call Img.AfficheImage(10) ' Affiche l'image toutes les lignes traitées.
Next Y
Loop While InfoAction = True ' Boucle tant que le traitement génère une action.
Call Img.AfficheImage(10) ' Affiche l'image définitive.
End SubVous retrouverez le code des fonctions du module VBO dans le tome 1.
Enfin, vous avez dû remarquer dans le code source, la procédure ChargeImageFormulaire, qui permet de charger en mémoire une image contenue dans un formulaire…
XIX. Utiliser les images contenues dans un formulaire▲
Lorsque vous diffuserez votre jeu d'arcade, il ne faudra pas oublier d'y joindre les images utilisées. Images qui peuvent être nombreuses. Par exemple, il m'a fallu 58 images pour l'animation d'une fusée dans un feu d'artifice. Sachant qu'il suffit d'un fichier supprimé par erreur pour faire planter votre animation, sans compter les risques de détournement des images qui vous ont pris tant de temps à réaliser, mieux vaut trouver une autre solution.
Pour rester compatible EXCEL - ACCESS, je vous propose de copier vos images dans un formulaire.
Sous ACCESS, configurez un formulaire indépendant, non modal, sans aucun style de bordure, et les images seront « attachées ».
L'ouverture du formulaire pour y récupérer ses images pourrait produire un effet visuel désagréable sans la possibilité de rendre le formulaire invisible, grâce à la procédure Opacité du module Img.
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hwnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
'---------------------------------------------------------------------------------------
Public Sub Opacité(PourcentOpacity As Integer)
'---------------------------------------------------------------------------------------
' Définit le pourcentage d'opacité de la fenêtre active (généralement un formulaire).
' PourcentOpacity : Pourcentage de l'opacité, en 0 et 100.
' Cette fonction est, en principe, appelée par FadeIn et FadeOut pour faire un effet graphique.
'-------------------------------------------------------------------------------------------
Call SetWindowLong(GetActiveWindow(), GWL_EXSTYLE, _
GetWindowLong(GetActiveWindow(), GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(GetActiveWindow(), 0, (PourcentOpacity / 100) * 255, 2)
End SubMêmes invisibles, les pixels sont bel et bien présents, et peuvent être récupérés avec BitBlt pour alimenter une mémoire image.
Cette procédure vous servira pour faire des fondus en ouverture et en fermeture dans vos jeux :
'---------------------------------------------------------------------------------------
Public Sub FonduOuverture(DuréeAttente As Integer)
'---------------------------------------------------------------------------------------
' Fait un fondu en ouverture(Fade In) sur la fenêtre active.
' DuréeAttente : durée d'attente en millisecondes dans la variation, en 0 et 100.
'---------------------------------------------------------------------------------------
Dim ik As Integer
For ik = 0 To 100 Step 2
Call Opacité(ik)
Call Sleep(DuréeAttente)
Next ik
End Sub
'---------------------------------------------------------------------------------------
Public Sub FonduFermeture(DuréeAttente As Integer)
'---------------------------------------------------------------------------------------
' Fait un fondu en fermeture (Fade Out) sur la fenêtre active.
' DuréeAttente : durée d'attente en millisecondes dans la variation, en 0 et 100.
'-------------------------------------------------------------------------------------------
Dim ik As Integer
For ik = 100 To 1 Step -2
Call Opacité(ik)
Call Sleep(DuréeAttente)
Next ik
End SubLes arguments de la procédure ChargeImageFormulaire sont proches de ceux de la procédure ChargeImageBMP. Mais à la place du nom du fichier source, il faut indiquer le nom du formulaire source et le nom de l'image que l'on souhaite charger en mémoire.
Peu importe où est située l'image dans le formulaire puisqu'elle est systématiquement déplacée au point d'origine 0,0 par ce traitement. Un formulaire peut donc contenir un grand nombre d'images.
'-------------------------------------------------------------------------------------------
Public Sub ChargeImageFormulaire(MyForm As Object, NomImage As String, _
NumImage As Integer, Optional Transparence As Long = -9, _
Optional AlignH As EnumAlignH = 0, Optional AlignV As EnumAlignV = 0)
'-------------------------------------------------------------------------------------------
' Ouvre le formulaire:
#If MonAppli = "Excel" Then
Call MyForm.Show(False)
#ElseIf MonAppli = "Access" Then
Call DoCmd.OpenForm(MyForm.Name)
#End If
' Rend le formulaire invisible:
Call Img.Opacité(0)
' Recherche le contrôle de l'image demandée:
For ImageNum = 0 To MyForm.Count - 1
If MyForm.Controls(ImageNum).Name = NomImage Then Exit For
Next ImageNum
' Place l'image en haut à gauche du formulaire:
MyForm.Controls(ImageNum).Top = 0
MyForm.Controls(ImageNum).Left = 0
MyForm.Repaint
' Récupère le contexte du formulaire et les coordonnées de l'image:
#If MonAppli = "Excel" Then
Anc_Hdc = GetDC(FindWindowA("ThunderDFrame", MyForm.Caption))
ImageMaxiX = Img.PointsEnPixelsX(MyForm.Controls(ImageNum).Width) - 1
ImageMaxiY = Img.PointsEnPixelsY(MyForm.Controls(ImageNum).Height) - 1
#ElseIf MonAppli = "Access" Then
Anc_Hdc = GetWindowDC(MyForm.hwnd)
ImageMaxiX = Img.PointsEnPixelsX(MyForm.Controls(ImageNum).Width / 20) - 1
ImageMaxiY = Img.PointsEnPixelsY(MyForm.Controls(ImageNum).Height / 20) - 1
#End If
' Copie l'image dans la mémoire avec l'alignement demandé:
Call Img.EffaceImage(NumImage)
Call Img.CopieImage(NumImage, NumImage, 0, 0, 0, 0, ImageMaxiX, ImageMaxiY)
Call BitBlt(Image(NumImage).Hdc, 0, 0, ImageMaxiX, ImageMaxiY, Anc_Hdc, 0, 0, SRCCOPY)
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)
' Ferme le formulaire:
#If MonAppli = "Excel" Then
Call MyForm.Hide
#ElseIf MonAppli = "Access" Then
DoCmd.Close acForm, MyForm.Name, acSaveNo
#End If
End SubXX. Conclusion▲
Mais pourquoi programmer en mode graphique ? La question était posée dans l'introduction de ce mémento. Je vous laissais entrevoir la possibilité de maîtriser chacun des pixels de l'écran, d'afficher des images et de gérer des animations, et aussi, de vous fournir les fonctionnalités qui vous permettront de programmer un jeu d'arcade.
Je pense que Snake est la démonstration que j'ai tenu mes promesses.
Reste à savoir si j'ai les talents requis pour transmettre mon savoir de façon compréhensible.
Par l'étude progressive des API utilisées, étude que j'espère ne pas être trop fastidieuse, j'ai souhaité vous expliquer la logique de la gestion du mode graphique. Plutôt que de vous livrer des procédures toutes faites dont vous ne comprendriez pas le sens. Armé de ces bases, vous pouvez maintenant développer les fonctions dont vous avez besoin. Pour un jeu d'arcade, pour animer vos applications ou pour impressionner votre entourage.
Si vous désirez vous lancer dans l'aventure des jeux d'arcade, vous trouverez sur Internet de nombreux Sprite en 2D. Que ceux qui ne savent pas dessiner se rassurent. Des sites sont même dédiés aux Sprite des jeux vidéo des premières générations.
Pour les bruitages, vous devrez trouver votre bonheur sur « freesoundeffects.com ».
N'hésitez pas à modifier ou compléter le module Img, comme je l'ai fait en y ajoutant la procédure EffetTransition qui offre 9 effets de transitions pour modifier l'image de fond.
Les plus perspicaces pourront consulter le tutoriel « ACCESS : Tutoriel d'utilisation simple de la classe ClImage » sur « developpez.com ».
Bonne programmation, et peut-être, rendez-vous dans un prochain mémento…
|
Laurent OTT. 2016 |
XXI. Les sources et images des exemples présentés▲
Nous mettons à votre disposition les fichiers sources des exemples présentés dans ce tutoriel.
Vous trouverez le jeu Snake dans cette archive ou dans cette source.
Les images bmp du feu d'artifice sont regroupées en trois parties : partie 1, partie 2 et partie 3. Les fichiers xls et d'autres compléments sont disponibles dans cette quatrième partie.