Soyez le premier à donner votre avis sur cette source.
Vue 10 149 fois - Téléchargée 913 fois
'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
29 avril 2008 à 22:29
Encore BRAVO !
29 avril 2008 à 20:41
29 avril 2008 à 19:28
Et Bravo pour la propreté du code et la clarté des explications !
21 avril 2008 à 16:27
21 avril 2008 à 16:05
Nice one!
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.