Trouver une ressource (Nouvelle version du moteur, plus rapide & pertinent, essayez le !)
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
TRANSPARENCE DES PICTUREBOX
Information sur la source
Description
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
- '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
-
-
-
'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
Fichier Zip
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
Télécharger le zip
Historique
- 20 avril 2008 20:48:19 :
- queqlues fautes d'orthographe
- 08 mai 2008 12:56:09 :
- Nettoyage du code, amélioration de la gestion de la transparence avant projet avec plusieurs pictureBox
- 08 mai 2008 12:58:59 :
- Nettoyage du code, amélioration de la gestion de la transparence. En particulier ajout d'un booléen indiquant que la transparence n'est pas nécessaire car les deux images n'ont pas de points communs.
- 08 mai 2008 13:00:31 :
- Nettoyage du code, amélioration de la gestion de la transparence en particulier par ajout d'un booléen précisant si le travail de transparence est nécessaire ou non (cas de deux images disjointes).
Sources de la même categorie
Commentaires
Discussions en rapport avec ce code source
|
Téléchargements
Logiciels à télécharger sur le même thème :
|