Transparence des picturebox

Soyez le premier à donner votre avis sur cette source.

Vue 9 759 fois - Téléchargée 846 fois

Télécharger le projet

Commenter

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 / 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

Télécharger le projet