Soyez le premier à donner votre avis sur cette source.
Vue 12 959 fois - Téléchargée 703 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 ' 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 '--------------------------------------------------------------------------------------- ' Procedure : ConstruireTransparence ' DateTime : 20/04/2008 14:22 ' Author : Patrice ' Purpose : Permet de dessiner l'ensemble des images passées par l'intermédiaire d'un tableau ' d'images. Les images sont classées par ordre de hiérarchie, les premières sont dessous ' les autres. Lors du dessin, les pixels dont la couleur est proche de la couleur ' de transparence sont ignorés. ' 4 paramètres ' Cadre : l'image résultat de l'ensemble des dessins ' Images() : un tbaleau d'images à dessiner ' CouleurTransparente : la couleur qui sera considérée comme transparente. ' Sensibilité : en fait ce sont les points dont la couleur est suffisamment proche de la ' couleur de transparence qui seront ignorés. L'argument sensibilité mesure cette ' proximité '--------------------------------------------------------------------------------------- ' Sub ConstruireTransparence(Cadre As PictureBox, Images() As PictureBox, _ ByVal CouleurTransparente As Long, ByVal Sensibilite As Long) 'Il faut définir les infos du cadre Dim InfoBitMapCadre As t_InfoBitMap Dim TabBitMapCadre As t_TabByte InfoBitMapCadre = ExtraireInfo(Cadre) TabBitMapCadre = ExtraireBits(InfoBitMapCadre, Cadre) Dim Index As Long Dim InfoBitMapImage As t_InfoBitMap Dim TabBitMapImage As t_TabByte Dim R As Byte, _ V As Byte, _ B As Byte 'Les composantes R, V, B de la couleur de transparence Dim R_Transp As Byte, _ V_Transp As Byte, _ B_Transp As Byte R_Transp = Rouge(CouleurTransparente) V_Transp = Vert(CouleurTransparente) B_Transp = Bleu(CouleurTransparente) Dim PremiereLigne As Long, DerniereLigne As Long, PremierPoint As Long, DernierPoint As Long Dim Ligne As Long, Point As Long 'on dessine chaque image dans l'ordre For Index = LBound(Images) To UBound(Images) InfoBitMapImage = ExtraireInfo(Images(Index)) TabBitMapImage = ExtraireBits(InfoBitMapImage, Images(Index)) PremiereLigne = Images(Index).Top DerniereLigne = Int(Images(Index).Top + Images(Index).Height - 1) PremierPoint = Images(Index).Left DernierPoint = Int(Images(Index).Left + Images(Index).Width - 1) For Ligne = PremiereLigne To DerniereLigne For Point = PremierPoint To DernierPoint GetPixelRVB TabBitMapImage, Point, Ligne, R, V, B 'Si la couleur du pixel est proche de la couleur de transparence (ici noire) 'il est ignoré If Not Proche(R, V, B, R_Transp, V_Transp, B_Transp, Sensibilite) Then SetPixelRVB TabBitMapCadre, Point, Ligne, R, V, B End If Next Point Next Ligne Erase TabBitMapImage.T Next Index Refresh Cadre, TabBitMapCadre, InfoBitMapCadre Cadre.Visible = True Erase TabBitMapCadre.T End Sub '--------------------------------------------------------------------------------------- ' Function : Proche ' DateTime : 09/05/2008 14:30 ' Author : Patrice ' Purpose : Ce prédicat (fonction booléenne) renvoie vrai si les couleurs (R1,V1,B1) et (R2,V2,B2) ' sont proches. C'est à dire la différence en valeur absolue de chacune de leurs ' composantes est inférieure au seuil de sensibilité. '--------------------------------------------------------------------------------------- ' Private Function Proche(R1 As Byte, V1 As Byte, B1 As Byte, R2 As Byte, V2 As Byte, B2 As Byte, Sensibilite As Long) Proche = False If Abs(R1 - R2) < Sensibilite Then If Abs(V1 - V2) < Sensibilite Then If Abs(B1 - B2) < Sensibilite Then Proche = True End If End If End If 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
Commentaires
@+
Non cela ne suffit pas car comme il est montré dans l'exemple il s'agit de remplacer les parties noires des images par de la tranparence. Pour utiliser la procédure il faut impérativement savoir quelle image est devant telle autre. De plus elles ne sont pas nécessairement installées sur la form dans cet ordre, sans compter qu'elles peuvent bouger (j'ai fait cet exemple pour réaliser un planétarium) et occuper des places distinctes selon le moment. DE plus elles ne sont pas nécessairement toutes visibles. Bien entendu on pourrait modifier leur place dans la hiérarchie graphique par ZOrder mais il est plus élégant de créer une procédure pour laquelle le nombre d'images n'est pas fixes et l'ordre dans lequel elle s'affichent est défini par l'utilisateur.
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.