begin process at 2012 02 16 19:42:41
  Trouver un code source :
 
dans
 
Accueil > 

Code

 > 

Graphique

 > TRANSPARENCE DES PICTUREBOX

TRANSPARENCE DES PICTUREBOX


 Information sur la source

Note :
10 / 10 - par 1 personne
10,00 / 10

  • 1

  • 2

  • 3

  • 4

  • 5

  • 6

  • 7

  • 8

  • 9

  • 10
Catégorie :Graphique Classé sous :graphisme, transparence, picturebox, images Niveau :Initié Date de création :20/04/2008 Date de mise à jour :08/05/2008 13:00:31 Vu / téléchargé :7 249 / 661

Auteur : Patrice H

Ecrire un message privé
Site perso
Commentaire sur cette source (5)
Ajouter un commentaire et/ou une note

 Description

Cliquez pour voir la capture en taille normale
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

Les Membres Club peuvent 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 du même auteur

Source avec Zip Source avec une capture TRANSPARENCE GÉNÉRALISÉE DES PICTUREBOX
Source avec Zip ASTRONOMIE
Source avec Zip Source avec une capture UN AUTRE SUDOKU

 Sources de la même categorie

Source avec Zip Source avec une capture Source .NET (Dotnet) VB10 - CRÉER VOS PROPRES CALQUES SUR UNE IMAGE par Duke49
Source avec Zip Source avec une capture Source .NET (Dotnet) CREER UN GIF ANIMÉ par Le Pivert
Source avec une capture GRAPH PHP COURBE DE CHARGE par s.defaye
Source avec Zip Source avec une capture BOULE DE CRISTAL par BLUEBIBUBBLE
VB6 - DÉPLACEMENT D'UN CONTRÔLE SUR UN SEGMENT DE DROITE DÉL... par ucfoutu

 Sources en rapport avec celle ci

Source avec Zip Source avec une capture Source .NET (Dotnet) FILTER : FAIRE DES MOSAIQUES D'IMAGES par raffika
Source avec Zip Source avec une capture Source .NET (Dotnet) TRANSPARENCE TEXTBOX ET PICTUREBOX par Le Pivert
Source avec Zip Source avec une capture TRANSPARENCE GÉNÉRALISÉE DES PICTUREBOX par Patrice H
Source avec Zip TEXTURES D'IMAGES par jmfmarques
Source avec Zip DÉLIRES D'UN PEINTRE par jmfmarques

Commentaires et avis

Commentaire de zen69 le 21/04/2008 16:05:41

Je n'ai pas tester mais le code me semble impec!

Nice one!

Commentaire de Patrice H le 21/04/2008 16:27:33

Merci.

Commentaire de philbar71 le 29/04/2008 19:28:16

Balaise !

Et Bravo pour la propreté du code et la clarté des explications !

Commentaire de Patrice H le 29/04/2008 20:41:40

Merci, mais il faut surtout remercier Jean-Marc qui m'a beaucoup aidé pour nettoyer le code.

Commentaire de philbar71 le 29/04/2008 22:29:15 10/10

Ce sera donc un remerciement collectif dont chacun a sa part.
Encore BRAVO !

 Ajouter un commentaire


Discussions en rapport avec ce code source dans le forum

Fusionner deux images superposées d'un PictureBox [ par airbag ] hello worldJe souhaite superposer deux images de tailles différentes, et enregistrer le tout dans un fichier image .bmp . C'est possible ça ??Pour l'i Transparence [ par Vincentsoft ] SalutJ'aimerai savoir comment on fait une transparence sur un picturebox.En fait, j'ai un certain nombre de pixel de telle couleur et je voudrai que c PictureBox avec zones d'images [ par lbs ] Existe-t-il un contrôle Image ou PictureBox capable de gérer les zones à l'intérieur d'une image comme en HTML (pour le survol à la souris évidement) transaction entre 2 images(par transparence) [ par Psychozarb ] voila l objet de ma requete, je veut faire apparaitre une image par dessus une autre mais lentement et par un effet de transparence : qd une apparait, Transparence des images [ par etsc ] Est ce quelqu'un pourrait me dire quel contrôle permet de supperposer des image en conservant leur transparcance??Merci@+ Image dans un picturebox [ par Hakushi ] Je suis en train de faire un projet pour afficher des images dans un picturebox mais quand l'image est plus grande que le form, je n'ai encore trouvé Coller des images dans une picturebox [ par AsterOwner ] Bon je sais que vous avez surement du répondre à mon problème mais j'ai pas encore trouver ce que je voulais...J'ai des images dans ma imagelist1 et j Comment charger une fois pour toutes des images dans des PictureBox [ par sb ] Le problème est que je dois à chaque fois recharger l'image d'une PictureBox lorsque je décharge une feuille la contenant.Quand mon programme comporte Transparence images [ par FireDraGon ] Comment peut on faire pour mettre une partie d'une image transparente sous vb ??? Redimentionner des images [ par jim462 ] J?ai crée une PictureBox et j?y ai inséré une image au format JPG mais mon image est beaucoup plus grande que la PictureBox et elle dépasse de celle-c


Nos sponsors


Sondage...

Comparez les prix

CalendriCode

Février 2012
LMMJVSD
  12345
6789101112
13141516171819
20212223242526
272829    

Consulter la suite du CalendriCode

Photothèque

 
Développement réalisé par Nicolas SOREL (Nix) avec l'aide de : Cyril DURAND et Emmanuel (EBArtSoft), Merci à Vincent pour ses précieux conseils.
CodeS-SourceS.com© Toute reproduction même partielle est interdite sauf accord écrit du Webmaster
CodeS-SourceS.com© est une marque déposée tous droits réservés

Google Coop CodeS-SourceS Google Coop CodeS-SourceS
Temps d'éxécution de la page : 4,493 sec (3)

Nous contacter | Annoncer sur CodeS-SourceS | Mentions légales