La manipulation des images par les API

Coller dans une page Excel une image provenant d'un fichier bmp
Coller dans une page Excel une image provenant d'un fichier bmp après en avoir modifié les couleurs
Modifier une image provenant d'un fichier bmp et l'enregistrer en gif
Animation par les API : Une voiture qui roule sur les barres d'outils d'Excel
Créer une image .gif à partir d'une grille Excel (VBA API)
Un logiciel de dessin sous Excel (VBA API)

Coller dans une page Excel une image provenant d'un fichier bmp

Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" _
(ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long

Sub copie_image()
Set img = LoadPicture("C:\zaza.bmp")
OpenClipboard 0
EmptyClipboard
SetClipboardData 2, img.Handle
CloseClipboard
Cells(1).Select
ActiveSheet.Paste
End Sub

La macro charge l'image dans la variable img grace à LoadPicture ;
puis ouvre le presse-papiers avec OpenClipboard 0
vide le presse-papiers par EmptyClipboard
charge l'image dans le presse-papiers grace à la fonction SetClipboardData (argument 2 pour indiquer que les données chargées correspondent à une image bitmap)
ferme le presse-papiers par CloseClipboard
puis colle le contenu du presse papier dans la feuille Excel avec l'instruction VBA Paste.

Cette macro présente il est vrai assez peu d'intérêt pratique, dans la mesure où le même résultat peut être obtenu sans effort avec :

Sub insère_image()
Cells(1).Select
ActiveSheet.Pictures.Insert ("C:\zaza.bmp")
End Sub

L'avantage de la première méthode est qu'elle permet d'intercepter l'image pour la modifier avant collage.

Coller dans une page Excel une image provenant d'un fichier bmp après en avoir modifié les couleurs

Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
      (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" _
      (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

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 modifie_couleurs()
'copie une image fichier, la modifie et l'enregistre
Dim bm_départ As BITMAP
Set img_départ = LoadPicture("C:\zaza.bmp")

GetObjectAPI img_départ.Handle, Len(bm_départ), bm_départ 'récupère le bitmap correspondant à l'image
larg = bm_départ.bmWidth
haut = bm_départ.bmHeight

fen = CreateCompatibleDC(GetDC(0)) 'crée un Devide Context (DC)
SelectObject fen, img_départ 'charge l'image ds le DC

hdc_fin = CreateCompatibleDC(GetDC(0))
img_fin = CreateCompatibleBitmap(GetDC(0), larg, haut) 'crée un bitmap pour l'img modifiée
SelectObject hdc_fin, img_fin 'charge le bitmap ds le DC

For X = 1 To larg
For Y = 1 To haut
Call SetPixel(hdc_fin, X, Y, GetPixel(fen, X, Y) - 100)
'(modifie la couleur des pixels)
Next
Next

OpenClipboard 0
EmptyClipboard
SetClipboardData 2, img_fin 'place le bitmap dans le presse-papiers
CloseClipboard

Cells(1).Select
ActiveSheet.Paste 'colle l'image modifiée
Selection.ShapeRange.Height = 100
End Sub

Modifier une image provenant d'un fichier bmp et l'enregistrer en gif

Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function SetClipboardData Lib "user32" _
      (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
     (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" _
     (ByVal hdc 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
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
Dim coord As RECT
Dim bm_départ As BITMAP
Dim img_fin
Dim img_départ

Sub modifie_couleurs()
'copie une image fichier, la modifie et l'enregistre

Set img_départ = LoadPicture("C:\rien.bmp")

GetObjectAPI img_départ.Handle, Len(bm_départ), bm_départ 'récupère le bitmap correspondant à l'image
larg = bm_départ.bmWidth
haut = bm_départ.bmHeight

fen = CreateCompatibleDC(GetDC(0)) 'crée un Devide Context (DC)
SelectObject fen, img_départ 'charge l'image ds le DC

hdc_fin = CreateCompatibleDC(GetDC(0))
img_fin = CreateCompatibleBitmap(GetDC(0), larg, haut) 'crée un bitmap pour l'img modifiée
SelectObject hdc_fin, img_fin 'charge le bitmap ds le DC

For X = 1 To larg
For Y = 1 To haut
Call SetPixel(hdc_fin, X, Y, GetPixel(fen, X, Y) - 100)
Next
Next
OpenClipboard 0
EmptyClipboard
SetClipboardData 2, img_fin
CloseClipboard
fen = FindWindow("XLMAIN", vbNullString)
Call GetWindowRect(fen, coord)
échx = Application.Width / (coord.Right - coord.Left)
échy = Application.Height / (coord.Bottom - coord.Top)
Set gr = Sheets(1).ChartObjects.Add(0, 0, échx * larg + 8, échy * haut + 8)
gr.Chart.Paste
gr.Chart.Export "c:\zaza2.gif", "GIF"
gr.Delete
MsgBox "l'image modifiée a été enregistrée sous c:\zaza2.gif"
End Sub

Sur le même principe, on peut facilement faire pivoter une image de 90° :
Il suffit de changer les dimension du bitmap recevant l'image modifiée (inverser hauteur et largeur) :
img_fin = CreateCompatibleBitmap(GetDC(0), haut, larg)
puis de copier le pixel du pount X,Y de la source au point Y,X de la cible :
Call SetPixel(hdc_fin, Y, X, GetPixel(fen, X, Y))

Animation par les API : Une voiture qui roule sur les barres d'outils d'Excel

Pas de problème avec les API pour écrire ou placer des pixels (et donc une image) n'importe où sur l'écran.
Pour déplacer l'image, il faut pouvoir l'effacer en restaurant le fond (par exemple les barres d'outils) puis reproduire l'image à un autre endroit.
Dernier problème, comment se débarasser du fond de l'image, par exemple, comment faire disparaitre la route sur laquelle roule la voiture ?
La solution la plus simple consiste à utiliser une copie de l'image détourée sur fond par exemple blanc (mais une autre couleur peut convenir si l'image utile contient du blanc), et un masque (image en noir et blanc représentant la voiture seule).
Pour cela on utilise la fonction BitBlt avec le paramètre &H8800C6 (SRCAND) pour coller les pixels du masque (noir et blanc) sur le fond (barres Excel), ce qui a pour effet de créer dans le fond, un "trou" ayant la forme de la voiture (là où le masque est noir).
On utilise une deuxième fois BitBlt, cette fois avec le paramètre &HEE0086 (SRCPAINT) pour coller dans les "trous", les pixels de l'image détourée :
BitBlt écran_DC, 15, 15, 82, 22, masque_DC, 0, 0, &H8800C6
BitBlt écran_DC, 15, 15, 82, 22, img_DC, 0, 0, &HEE0086
On peut aisément préparer l'image détourée et le masque à partir de l'image initiale en utilisant des logiciels de dessin comme paint ou photoshop.
On peut aussi préparer directement le masque par programme à partir de l'image détourée.

Le programme ci-après (fichier Excel à télécharger) part d'un fichier image de voiture sur fond blanc, r21.bmp.
Il faut décompresser l'archive zip (fichier r21bis.xls et r21.bmp) dans un seul répertoire (par exemple Temp) avant d'ouvrir le fichier Excel.
La macro récupère les pixels de l'image r21.bmp, prépare un masque, sauvegarde l'image de fond de l'écran (page Excel en cours) puis lance l'animation :
fait un trou dans l'image d'écran en collant le masque, y colle l'image sans son fond, attend quelques millisecondes puis efface tout (en recopiant la sauvegarde de l'image d'écran par BitBlt) avant de recommencer quelques pixels plus loin pour faire avancer la voiture.
La voiture (débarrassée de son fond), se déplace en avant ou en arrière n'importe où sur l'écran, sans se soucier de ce qui s'y trouve déjà (barres d'outils, feuille Excel...).

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 SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function CreateHalftonePalette Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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
Declare Function SetBkMode Lib "gdi32" ( ByVal hdc As Long, ByVal nBkMode As Long) As Long
Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
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 la_r_21()
Dim bm_départ As BITMAP

'récupérer le pointeur du contexte de sortie de l'écran
écran_DC = GetDC(0)

'récupérer l'image
'et ses coordonnées en pixel
Set img_départ = LoadPicture(ThisWorkbook.Path & "\r21.bmp")
GetObjectAPI img_départ.Handle, Len(bm_départ), bm_départ 'récupère le bitmap correspondant à l'image
larg = bm_départ.bmWidth
haut = bm_départ.bmHeight
lmax = 500 + larg
hmax = 100 + haut

'créer un bitmap img_ini, dans le imgDC pour y accueillir l'image
img_DC = CreateCompatibleDC(écran_DC)
img_DCOld = SelectObject(img_DC, img_départ)

'copie de l'écran à utiliser pour raffraichir à chaque mouvement de l'img
écran_svg = CreateCompatibleBitmap(écran_DC, lmax, hmax)
écranDC_svg = CreateCompatibleDC(écran_DC)
écranDC_svgOld = SelectObject(écranDC_svg, écran_svg)
Call BitBlt(écranDC_svg, 0, 0, lmax, hmax, écran_DC, 0, 0, &HCC0020)

'récupérer la palette du dc en cours
palette = CreateHalftonePalette(écran_DC)
OleTranslateColor vbWhite, palette, lMaskColor

'créer un bitmap tampon qui accueillera l'image finale (auto + fond xl)
tampon = CreateCompatibleBitmap(écran_DC, larg, haut)
tampon_DC = CreateCompatibleDC(écran_DC)
tamponOld = SelectObject(tampon_DC, tampon)
paletteBufferOld = SelectPalette(tampon_DC, palette, True)
RealizePalette tampon_DC

'créer un bitmap auto, qui accueillera l'auto sans son fond
auto = CreateCompatibleBitmap(écran_DC, larg, haut)
auto_DC = CreateCompatibleDC(écran_DC)
autoOld = SelectObject(auto_DC, auto)
paletteOld = SelectPalette(auto_DC, palette, True)
RealizePalette auto_DC
SetBkColor auto_DC, GetBkColor(img_DC)
SetTextColor auto_DC, GetTextColor(img_DC)

'créer un bitmap monochrome pour le masque(nb)
masque = CreateBitmap(larg, haut, 1, 1, ByVal 0&)
masque_DC = CreateCompatibleDC(écran_DC)
masqueOld = SelectObject(masque_DC, masque)

'copier l'image de l'auto dans son auto_DC (et retirer le blanc)
BitBlt auto_DC, 0, 0, larg, haut, img_DC, 0, 0, &HCC0020
SetBkColor auto_DC, lMaskColor 'utiliser mskcolor(blanc) comme couleur de fond
SetTextColor auto_DC, vbWhite

'copier auto_DC ds le BM monochrome pour créer le masque
BitBlt masque_DC, 0, 0, larg, haut, auto_DC, 0, 0, &HCC0020
SetTextColor auto_DC, vbBlack
SetBkColor auto_DC, vbWhite 'remettre la couleur du fond à blanc
BitBlt auto_DC, 0, 0, larg, haut, masque_DC, 0, 0, &H220326

'lancer les boucles pour le déplacement
For st = 1 To -1 Step -2
ht = 50
For x = 250 - st * 250 To 250 + st * 250 Step st * 10
y = 50 + 50 * st - st * x / 10

'copier l'écran xl dans le tampon
BitBlt tampon_DC, 0, 0, larg, haut, écran_DC, x, y, &HCC0020

'effacer la partie qui doit être transparente en copiant le masque ds le buff
BitBlt tampon_DC, 0, 0, larg, haut, masque_DC, 0, 0, &H8800C6

'coller l'image du fond dans les trous noirs du buffer (paint)
BitBlt tampon_DC, 0, 0, larg, haut, auto_DC, 0, 0, &HEE0086

'copier le résultat sur l'écran
BitBlt écran_DC, x, y, larg, haut, tampon_DC, 0, 0, &HCC0020

Sleep 50 'arret sur image

'raffraichir l'écran
Call BitBlt(écran_DC, 0, 0, lmax, hmax, écranDC_svg, 0, 0, &HCC0020)
Next 'déplacement suivant

'écrire un commentaire sur l'écran
Call SetBkMode(écran_DC, 1)
Call SetTextColor(écran_DC, vbRed)
txt = "STOP, barres fragiles !"
Call TextOut(écran_DC, lmax, 0.5 * hmax, txt, Len(txt))

Next 'aller en arrière

'ménage (libérer la mémoire)
DeleteObject SelectObject(auto_DC, autoOld)
SelectPalette auto_DC, paletteOld, True
RealizePalette auto_DC
DeleteDC auto_DC
DeleteObject SelectObject(tampon_DC, tamponOld)
SelectPalette tampon_DC, paletteBufferOld, True
RealizePalette tampon_DC
DeleteDC tampon_DC
DeleteObject SelectObject(masque_DC, masqueOld)
DeleteDC masque_DC
DeleteObject SelectObject(écranDC_svg, écranDC_svgOld)
DeleteDC écranDC_svg
DeleteObject SelectObject(img_DC, img_DCOld)
DeleteDC img_DC
ReleaseDC 0, écran_DC
DeleteObject m_paletteHalftone

End Sub

La macro présentée ci-dessus présente un inconvénient : elle ne peut fonctionner que si l'image de la voiture a préalablement été enregistrée sur le disque sous forme de fichier.
On peut imaginer d'utiliser une image insérérée directement dans le fichier Excel (par exemple dans une page cachée du fichier).
Le fichier à télécharger en cliquant ici (fichier Excel zippé) fonctionne sur ce principe. Attention, il ne marche qu'avec XL97.

Une autre solution consiste à enregistrer l'image sous forme de tableau de couleurs dans une page Excel cachée (en utilisant la fonction GetPixel), et de la restituer en utilisant la fonction SetPixel (cliquez ici pour télécharger le fichier exemple). Seul inconvénient, le chargement de l'image pixel par pixel est un peu long.

Créer une image .gif à partir d'une grille Excel (VBA API)

cliquez ici pour télécharger le fichier .zip

Un logiciel de dessin sous Excel (VBA API)
cliquez ici pour télécharger le fichier .zip

A partir d'une image (fichier image quelconque ou bien image copiée dans le presse-papiers), le programme va créer une "image Excel", grille Excel constituée de petites cellules carrées contenant chacune un pixel de l'image (pour limiter les durées de chargement des images, le nombre de pixels a été limité à 10 000, ce qui est suffisant pour de petites images, mais pas idéal pour vos photos de vacances).
L'image peut aussi bien être directement "dessinée" sous Excel.
(Attention, le nombre de couleurs Excel étant limité, certaines images prennent des couleurs bizarres sous Excel. Ne vous en inquiétez pas, les couleurs initiales seront restaurées sur l'image finale).

L'image Excel peut facilement être modifiée en changeant la couleur des cellules (à la souris ou par macro).
Dans le fichier proposé, il suffit de sélectionner dans une palette la couleur du "pinceau" et de cliquer sur la cellule ou la zone à repeindre.

Une fois l'image modifiée, une macro l'enregistre au format .gif.

Finalement, il s'agit d'une médiocre parodie de logiciels du genre paint.
Son avantage est d'être completement sous contrôle de l'utilisateur via VBA, ce qui permet une programmation très facile des modifications de l'image (superpositions d'images, création automatisée de séries d'images pour des animations...).

cliquez ici pour télécharger le fichier .zip

Les API
Quelques sites utiles sur les API
Le jargon API