Il s'agit de dessiner deux pictureBox se chevauchant et en définissant une couleur de transparence et une sensibilité permettant à celle du dessous d'être visible pour les pixels de couleur suffisamment proche de la couleur de tranparence. Un exemple est donné, montrant la terre tournant autour du soleil.
08/05/2008 midi
J'ai rajouté des commentaires, supprimé ce qui n'était pas nécessaire.
J'ai surtout ajouté une info qui n'existait pas et qui est indispensable au bon fonctionnement.
Le principe est de prendre deux pictureBox et d'en construire un troisième, intersection des deux premiers, que l'on affichera sur les ceux-ci.
Ce n'est possible que si le pictureBox résultat est placé devant tous les autres dans la hiérarchie graphique (utilisation de la méthode ZOrder)
Sur le même principe je suis en train de faire un module permettant la transparence pour plusieurs pictureBox sur un même fond.
Le source donné ci-dessous est celui du module gérant la transparence.
Source / Exemple :
'D'après un travail de DARKSIDIOUS (http://www.vbfrance.com/auteur/DARKSIDIOUS/13557.aspx)
'téléchargeable ici : http://www.vbfrance.com/code.aspx?ID=21354
'avec l'aide de Jean-Marc (http://www.vbfrance.com/auteur/JEANMARCN2/205448.aspx)
'20 avril 2008
Option Explicit
'
' Déclaration des types privées pour les API
'
Private Const pixR As Integer = 3 ' index du pixel de couleur rouge
Private Const pixV As Integer = 2 ' index du pixel de couleur vert
Private Const pixB As Integer = 1 ' index du pixel de couleur bleu
' structure stockant les informations des en-têtes bitmap
Private Type t_EnteteBitMap
Taille As Long ' il s'agit du nombre de bits décrivant l'entête
Largeur As Long
Hauteur As Long
NbPlans As Integer ' pour du BMP 1 plan
NbBits As Integer ' il s'agit du nombre de bits décrivant le pixel (32 bits ici)
Compression As Long ' pour du BMP, compression = 0
TailleImage As Long
XPixelsParMetre As Long
YPixelsParMetre As Long
biClrUsed As Long ' ?
biClrImportant As Long ' ?
End Type
Private Type t_Couleur
Bleu As Byte
Vert As Byte
Rouge As Byte
Reserve As Byte
End Type
Private Type t_InfoBitMap
Entete As t_EnteteBitMap
Couleur As t_Couleur
End Type
Private Type t_TabByte
T() As Byte
End Type
Private Type t_Rectangle
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Fonction permettant de définir les bits d'un bitmap dans un DC
Private Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As t_InfoBitMap, _
ByVal wUsage As Long) As Long
' Fonction permettant de récupèrer les bits d'une image dans un tableau passé en paramètre
' hdc est un handle sur un device context
' hBitMap est un identifiant de bitmap
' nStartScan est l'octet où commence la récupération des bits
' nScanLines est le nombre de lignes à récupérer
' lpBits pointe sur un buffer capable de recevoir les données du bitmap
' lpBitMapInfo est d'un type capable de recevoir les informations de bitmap
' wUsage vaut 0 pour une table de couleurs en RGB
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nScanLines As Long, _
lpBits As Any, _
lpBitmapInfo As t_InfoBitMap, _
ByVal wUsage As Long) As Long
' The IntersectRect function calculates the intersection of two source rectangles and places
' the coordinates of the intersection rectangle into the destination rectangle.
Private Declare Function IntersectRect Lib "user32" (lpDestRect As t_Rectangle, _
lpSrc1Rect As t_Rectangle, _
lpSrc2Rect As t_Rectangle) As Long
Private Declare Function SetRect Lib "user32" (lpRect As t_Rectangle, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
'---------------------------------------------------------------------------------------
' Procedure : ConstruireResultat
' DateTime : 20/04/2008 14:22
' Author : Patrice
' Purpose : Permet de construire l'image du rectangle intersection des images Devant
' et Derriere. Si le pixel Devant est suffisamment proche de la couleur de transparence
' il est remplacé par le pixel Derriere
' Cela nécessite 5 paramètres
' Result : l'image rectanguealire résultat
' Devant : l'image qui est devant
' Derriere : l'image qui sera derriere
' CouleurTransparente : la couleur qui sera considérée comme transparente c'est à dire
' que les points de Devant de cette couleur dans l'intersection des deux images seront
' remplacés par les points de Derriere
' Sensibilité : en fait ce sont les points dont la couleur est suffisamment proche de la
' couleur de transparence qui seront remplacés. L'argument sensibilité mesure cette
' proximité
'---------------------------------------------------------------------------------------
'
Sub ConstruireTransparence(Result As PictureBox, Devant As PictureBox, Derriere As PictureBox, _
ByVal CouleurTransparente As Long, ByVal Sensibilite As Long, _
ByRef transparence As Boolean)
Dim InfoBitMapDerriere As t_InfoBitMap
Dim TabBitMapDerriere As t_TabByte
Dim InfoBitMapDevant As t_InfoBitMap
Dim TabBitMapDevant As t_TabByte
Dim InfoBitMapR As t_InfoBitMap
Dim TabBitMapR As t_TabByte
Dim x As Long
Dim y As Long
Dim R As Byte, _
V As Byte, _
B As Byte
'Les composantes R, V, B de la couleur de transparence
Dim R_Transp As Long, _
V_Transp As Long, _
B_Transp As Long
' Reinitialiser resultat
Set Result.Picture = LoadPicture("")
InfoBitMapDerriere = ExtraireInfo(Derriere)
TabBitMapDerriere = ExtraireBits(InfoBitMapDerriere, Derriere)
InfoBitMapDevant = ExtraireInfo(Devant)
TabBitMapDevant = ExtraireBits(InfoBitMapDevant, Devant)
'les résultat c'est l'intersection des deux pictures
'si cette intersection est vide, il n'y a aps de transparence à traiter
transparence = TrouverTailleResultat(Result, Devant, Derriere)
If Not transparence Then Exit Sub
R_Transp = Rouge(CouleurTransparente)
V_Transp = Vert(CouleurTransparente)
B_Transp = Bleu(CouleurTransparente)
InfoBitMapR = ExtraireInfo(Result)
ReDim TabBitMapR.T(1 To 4, _
Result.Left To Result.Left + Result.Width - 1, _
Result.Top To Result.Top + Result.Height - 1)
For x = Result.Left To Result.Left + Result.Width - 1
For y = Result.Top To Result.Top + Result.Height - 1
GetPixelRVB TabBitMapDevant, x, y, R, V, B
'Si la couleur du pixel est proche de la couleur de transparence (ici noire)
'on remplace le pixel par celui de Derriere
If (Abs(R - R_Transp) < Sensibilite) Then
If (Abs(V - V_Transp) < Sensibilite) Then
If (Abs(B - B_Transp) < Sensibilite) Then
GetPixelRVB TabBitMapDerriere, x, y, R, V, B
End If
End If
End If
SetPixelRVB TabBitMapR, x, y, R, V, B
Next y
Next x
Refresh Result, TabBitMapR, InfoBitMapR
Result.Visible = True
Erase TabBitMapDerriere.T, TabBitMapDevant.T, TabBitMapR.T
End Sub
'---------------------------------------------------------------------------------------
' Procedure : TrouverTailleResultat
' DateTime : 20/04/2008 14:30
' Author : Patrice
' Purpose : Ce prédicat (fonction booléenne) renvoie les dimensions d'un PictureBox (R) résultat de
' l'intersection des deux PictureBox A et B. Si l'intersectiion est vide, le prédicat
' renvoie false.
'---------------------------------------------------------------------------------------
'
Private Function TrouverTailleResultat(R As PictureBox, A As PictureBox, B As PictureBox) As Boolean
Dim Rect_R As t_Rectangle, _
Rect_A As t_Rectangle, _
Rect_B As t_Rectangle
Dim res As Long
SetRect Rect_A, A.Left, A.Top, A.Left + A.Width - 1, A.Top + A.Height - 1
SetRect Rect_B, B.Left, B.Top, B.Left + B.Width - 1, B.Top + B.Height - 1
res = IntersectRect(Rect_R, Rect_A, Rect_B)
If res = 0 Then
TrouverTailleResultat = False
Exit Function
End If
R.Left = Rect_R.Left
R.Top = Rect_R.Top
R.Width = Rect_R.Right - Rect_R.Left + 1
R.Height = Rect_R.Bottom - Rect_R.Top + 1
TrouverTailleResultat = True
End Function
'---------------------------------------------------------------------------------------
' Procedure : ExtraireInfo
' DateTime : 20/04/2008 14:31
' Author : Patrice
' Purpose : On renvoie les infos d'une PictureBox (margeur, hauteur, ...)
'---------------------------------------------------------------------------------------
'
Private Function ExtraireInfo(PictBox As PictureBox) As t_InfoBitMap
Dim InfoBitMap As t_InfoBitMap
InfoBitMap.Entete.Taille = Len(InfoBitMap.Entete)
InfoBitMap.Entete.Largeur = PictBox.ScaleWidth
InfoBitMap.Entete.Hauteur = -PictBox.ScaleHeight
InfoBitMap.Entete.NbPlans = 1
InfoBitMap.Entete.NbBits = 32
InfoBitMap.Entete.Compression = 0
InfoBitMap.Entete.TailleImage = 4 * PictBox.ScaleWidth * PictBox.ScaleHeight
ExtraireInfo = InfoBitMap
End Function
'---------------------------------------------------------------------------------------
' Procedure : ExtraireBits
' DateTime : 20/04/2008 14:20
' Author : Patrice
' Purpose : On renvoie un tableau de bits à trois dimensions
' un pixel est défini par sa position (x,y) et sa couleur sur 4 bytes (byte1 = bleu,
' byte2 = vert, byte3 = rouge, byte4=?).
' première dimension : 1 à 4 couleur
' deuxième dimension : lignes
' troisième dimension : colonnes
' Tel que présenté, la quotité de rouge du pixel de coordonnées (25,13), ligne 25
' collone 13 sera T(pixR,25,13)
'---------------------------------------------------------------------------------------
'
Private Function ExtraireBits(InfoBitMap As t_InfoBitMap, PictBox As PictureBox) As t_TabByte
Dim TableauDeBitsImage As t_TabByte
Dim X_Min As Long, _
X_Max As Long, _
Y_Min As Long, _
Y_Max As Long
' Le With va nettement améliorer la lisibilité et surtout les performances
With PictBox
X_Min = .Left
X_Max = .Left + .Width - 1
Y_Min = .Top
Y_Max = .Top + .Height - 1
ReDim TableauDeBitsImage.T(1 To 4, X_Min To X_Max, Y_Min To Y_Max) As Byte
Call GetDIBits(.hdc, _
.Image, _
0, _
.ScaleHeight, _
TableauDeBitsImage.T(1, X_Min, Y_Min), _
InfoBitMap, _
0)
End With
ExtraireBits = TableauDeBitsImage
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetPixelRVB
' DateTime : 20/04/2008 14:17
' Author : Patrice
' Purpose : Permet de récupèrer la couleur (les composantes RGB) d'un pixel de l'image
'---------------------------------------------------------------------------------------
'
Private Sub GetPixelRVB(TabBitMap As t_TabByte, _
ByVal x As Long, _
ByVal y As Long, _
ByRef R As Byte, _
ByRef V As Byte, _
ByRef B As Byte) _
R = TabBitMap.T(pixR, x, y)
V = TabBitMap.T(pixV, x, y)
B = TabBitMap.T(pixB, x, y)
End Sub
'---------------------------------------------------------------------------------------
' Procedure : SetPixelRVB
' DateTime : 20/04/2008 14:13
' Author : Patrice
' Purpose : Permet de définir la couleur d'un pixel de l'image
' Params : x, y : Coordonnées en pixel du point de l'image dont on veut définir la couleur
' R, V, B : composantes rouge, verte et bleue du pixel à appliquer
'---------------------------------------------------------------------------------------
'
Public Sub SetPixelRVB(TabBitMap As t_TabByte, _
ByVal x As Long, _
ByVal y As Long, _
ByVal R As Byte, _
ByVal V As Byte, _
ByVal B As Byte)
TabBitMap.T(pixR, x, y) = R
TabBitMap.T(pixV, x, y) = V
TabBitMap.T(pixB, x, y) = B
End Sub
'---------------------------------------------------------------------------------------
' Procedure : Refresh
' DateTime : 20/04/2008 13:51
' Author : Patrice
' Purpose : Permet d'insérer l'image stockée dans le tableau dans le PictureBox
'---------------------------------------------------------------------------------------
'
Private Sub Refresh(PictBox As PictureBox, TabBitMap As t_TabByte, InfoBitMap As t_InfoBitMap)
Call SetDIBits(PictBox.hdc, _
PictBox.Image, _
0, _
PictBox.ScaleHeight, _
TabBitMap.T(1, LBound(TabBitMap.T, 2), _
LBound(TabBitMap.T, 3)), _
InfoBitMap, _
0)
End Sub
'renvoie la composante bleue de la couleur
Private Function Bleu(ByVal Couleur As Long) As Byte
'Couleur = 65536 * Bleu + 256* Vert + Rouge
Bleu = ((Couleur \ 65536) And &HFF)
End Function
'renvoie la composante verte de la couleur
Private Function Vert(ByVal Couleur As Long) As Byte
'Couleur = 65536 * Bleu + 256* Vert + Rouge
Vert = ((Couleur \ 256) And &HFF)
End Function
'renvoie la composante rouge de la couleur
Private Function Rouge(ByVal Couleur As Long) As Byte
'Couleur = 65536 * Bleu + 256* Vert + Rouge
Rouge = (Couleur And &HFF)
End Function
Conclusion :
Ce travail doit beaucoup à DARKSIDIOUS (
http://www.vbfrance.com/auteur/DARKSIDIOUS/13557.aspx)et son source "fusion rapide de deux images" (2004) dont je me suis beaucoup inspiré.
(téléchargeable ici :
http://www.vbfrance.com/code.aspx?ID=21354)
Un grand merci aussi à Jean-Marc (
http://www.vbfrance.com/auteur/JEANMARCN2/205448.aspx) qui m'a aidé à nettoyer mon code
20 avril 2008
Mise à jour : 08 mai 2008
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.