TRANSPARENCE DES PICTUREBOX

'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