Dessiner un halo de couleur

Soyez le premier à donner votre avis sur cette source.

Snippet vu 5 605 fois - Téléchargée 18 fois

Contenu du snippet

dessine un halo coloré en fonction de la couleur choisie,
bit: image bitmap, l : position x, t : position y, couleur : ex "vert", diamètre_noyau : luminosité intérieure, diamètre2: nécessairement supérieure au diamètre du noyau, diamètre3: pour les couleurs composées (ex: "rose et bleu") et supérieure au diamètre 2
j'ai essayé de l'optimiser comme je pouvait afin qu'il soit le plus rapide possible

Source / Exemple :


Function halo(ByVal bit As Bitmap, ByVal l As Integer, ByVal t As Integer, ByVal couleurs As String, ByVal diametre_noyau_en_pixel As Integer, ByVal diametre_2_en_pixel As Integer, Optional ByVal diametre_3_en_pixel As Integer = 1)
        Dim dist_rouge, dist_vert, dist_bleu As Single
        Select Case couleurs
            Case Is = "blanc"
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "rouge"
                dist_rouge = 255 / diametre_2_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "vert"
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_2_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "bleu"
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_2_en_pixel * 2
            Case Is = "jaune"
                dist_rouge = 255 / diametre_2_en_pixel * 2
                dist_vert = 255 / diametre_2_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "rose"
                dist_rouge = 255 / diametre_2_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_2_en_pixel * 2
            Case Is = "turquoise"
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_2_en_pixel * 2
                dist_bleu = 255 / diametre_2_en_pixel * 2
            Case Is = "jaune et rouge"
                dist_rouge = 255 / diametre_2_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_3_en_pixel * 2
            Case Is = "jaune et vert" 
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_2_en_pixel * 2
                dist_bleu = 255 / diametre_3_en_pixel * 2
            Case Is = "rose et rouge" 
                dist_rouge = 255 / diametre_2_en_pixel * 2
                dist_vert = 255 / diametre_3_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "rose et bleu" 
                dist_rouge = 255 / diametre_noyau_en_pixel * 2
                dist_vert = 255 / diametre_3_en_pixel * 2
                dist_bleu = 255 / diametre_2_en_pixel * 2
            Case Is = "turquoise et vert" 
                dist_rouge = 255 / diametre_3_en_pixel * 2
                dist_vert = 255 / diametre_2_en_pixel * 2
                dist_bleu = 255 / diametre_noyau_en_pixel * 2
            Case Is = "turquoise et bleu" 
                dist_rouge = 255 / diametre_3_en_pixel * 2
                dist_vert = 255 / diametre_noyau_en_pixel * 2
                dist_bleu = 255 / diametre_2_en_pixel * 2
        End Select
        Dim r, g, b As Integer
        Dim dist, rm, gm, bm As Integer
        'méthode plus rapide que getpixel:
        Dim diametre_max As Integer
        If diametre_3_en_pixel > diametre_2_en_pixel Then
            diametre_max = diametre_3_en_pixel
        Else
            If diametre_noyau_en_pixel > diametre_2_en_pixel Then
                diametre_max = diametre_noyau_en_pixel
            Else
                diametre_max = diametre_2_en_pixel
            End If
        End If
        Dim w1 As Integer = bit.Width
        Dim h1 As Integer = bit.Height
        Dim w2 As Integer = l - diametre_max / 2
        Dim h2 As Integer = t - diametre_max / 2
        Dim w3 As Integer = l + diametre_max / 2
        Dim h3 As Integer = t + diametre_max / 2
        If w2 < 0 Then w2 = 0
        If h2 < 0 Then h2 = 0
        If w3 > w1 Then w3 = w1
        If h3 > h1 Then h3 = h1
        Dim bmpData As Imaging.BitmapData = bit.LockBits(New Rectangle(0, 0, w1, h1), System.Drawing.Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format32bppArgb)
        Dim newPixel(w1 * h1 * 4 - 1) As Byte
        Runtime.InteropServices.Marshal.Copy(bmpData.Scan0, newPixel, 0, newPixel.Length)
        For w = w2 To w3 - 1 Step 1
            For h = h2 To h3 - 1 Step 1
                dist = Math.Round(Math.Sqrt((t - h) ^ 2 + Math.Abs(l - w) ^ 2), 0)
                rm = 255 - dist * dist_rouge : If rm < 0 Then rm = 0
                gm = 255 - dist * dist_vert : If gm < 0 Then gm = 0
                bm = 255 - dist * dist_bleu : If bm < 0 Then bm = 0
                'méthode plus rapide que setpixel:
                r = newPixel((w1 * h + w) * 4 + 2) + rm
                g = newPixel((w1 * h + w) * 4 + 1) + gm
                b = newPixel((w1 * h + w) * 4 + 0) + bm
                If r > 255 Then r = 255 : If r < 0 Then r = 0
                If g > 255 Then g = 255 : If g < 0 Then g = 0
                If b > 255 Then b = 255 : If b < 0 Then b = 0
                newPixel((w1 * h + w) * 4 + 2) = r
                newPixel((w1 * h + w) * 4 + 1) = g
                newPixel((w1 * h + w) * 4 + 0) = b
            Next
        Next
        Runtime.InteropServices.Marshal.Copy(newPixel, 0, bmpData.Scan0, newPixel.Length)
        bit.UnlockBits(bmpData)
        Return bit
    End Function

A voir également

Ajouter un commentaire Commentaires
Messages postés
26
Date d'inscription
dimanche 27 janvier 2008
Statut
Contributeur
Dernière intervention
7 juillet 2019

Merci! je vais essayer de refaire cette fonction
Messages postés
14788
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
1 mai 2021
155
Bonsoir,

La partie de calcul de la couleur m'intrigue, je trouve que ta manière de préciser la couleur est plutôt rigide (on ne peut pas spécifier la couleur désirée, on est coincé par tes choix).

Je te propose un code, à toi de voir si ça te convient :

Il te faut une structure nommée tColor contenant 2 attributs :
- Position As Double : Distance de la couleur
- Color As Color : Couleur de la position

Ensuite, cette fonction te calcul la couleur adaptée par rapport à la liste et la distance :
Private Function GetColorForPosition(Byval pPosition as Double,Byval ptColors() as tColor) as Color
Dim lMinColor as tColor
Dim lMaxColor as tColor

lMinColor.Position=0
lMaxcolor.Position=0

'Recherche des 2 couleurs les plus proches
For Each llColor As tColor In ptColors
If lColor.Position>pPosition andalso lMaxColor.Position>lColor.Position Then
lMaxColor=lColor
elseif lColor.Position<pPosition andalso lMinColor.Position<lColor.Position Then
lMinColor=lColor
End If
Next

'Si il y a qu'une seule couleur, on la retourne
If lMinColor.Position=0 then
Return lMaxColor.Color
elseif lMaxColor.Position=0 Then
Return lMinColor.Color
End If

'Sinon, on fait le mélange
Dim lR as integer, lG as integer, lB as integer lA as integer, lRatio as Double

lRatio=(lMinColor.Position-pPosition)/(lMaxColor.Position-lMinColor.Position)

lR=CInt(lRatio*lMinColor.Color.R+(1-lRatio)*lMaxColor.Colo.R)
lG=CInt(lRatio*lMinColor.Color.G+(1-lRatio)*lMaxColor.Colo.G)
lB=CInt(lRatio*lMinColor.Color.B+(1-lRatio)*lMaxColor.Colo.B)
lA=CInt(lRatio*lMinColor.Color.A+(1-lRatio)*lMaxColor.Colo.A)

Return Color.FromArgb(lA,lR,lG,lB)
End Function

Paramètres :
pPosition : Distance du centre
ptcolors, tableau de tColor pour lister les couleurs et les distances

L'avantage, c'est plus souple, on peut mettre plus de couleurs que dans ta proposition et le fait d'avoir séparer ce traitement rend le code un peu plus clair, je trouve.
(Bonus, elle gère les 4 composantes, pas que 3)

Cordialement.
>
Messages postés
14788
Date d'inscription
vendredi 14 mars 2003
Statut
Modérateur
Dernière intervention
1 mai 2021

Cher NHenry, Merci.
Je me posais récemment la question (2015-2010)=5 ans.
Ce qui m'amène a penser:
Public Class Cloud 'Matrice de dispersion

    Dim L As Integer 'Lignes
    Dim C As Integer 'Colonnes 
    Friend Q As Integer 'Quantité d'éléments a disperser.

    Dim M As Integer 'Nombre de cellules disponibles par élément.
    Dim Surjection As Boolean = False ' ou d'éléments par cellule.

    'Linéaristion d'une matrice de dimensions finies.
    Friend Function Indice(Coordonnee() As Integer, Dimensions() As Integer) As Integer
        Dim T As Integer = 0
        For Each Position As Integer In Coordonnee
            'Par quoi on commence ?
        Next
        Return T
    End Function
    'Qu'on ait une, deux, ou plus de dimensions c'est pareil. Pourquoi ça perturbe ?
    Friend Function Coordonnee(Indice As Integer, Dimensions() As Integer) As Integer()
        'Vaut-il mieux donner la priorité aux dimensions (Pondérer les dimensions ou les distances ?)
    End Function

    'Retourne la position d'un élément. (Surjection supposée=False)
    Friend Function PositionBateau(indice As Integer) As Point
        Dim Drm As Integer = indice * M 'Distribution régulièrement moyenne
        Dim Y = Int(Drm / C)
        Dim X = Int(Drm Mod C)
        Return New Point(X, Y)
    End Function

    Sub Init(Lignes As Integer, Colonnes As Integer, Quantite As Integer)
        L = Lignes
        C = Colonnes
        Q = Quantite
        Dim TCells As Integer = L * C
        If TCells > Q Then
            M = TCells / Q
        Else
            Surjection = True
            M = Q / TCells
        End If
    End Sub

    Sub init(Map As Bitmap, S As String)
        Init(Map.Width, Map.Height, 8 * S.Length)
    End Sub

End Class


De quoi m'amuser.....

EDIT: Ajout de la coloration syntaxique.

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.