Soyez le premier à donner votre avis sur cette source.
Vue 6 192 fois - Téléchargée 554 fois
'A mettre dans un module 'Déclaration des API et des variables 'L'API SetPixelV change la couleur d'un point donné de coordonnées x et y. 'crColor c'est la nouvelle couleur pour cet point. Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Byte ' L'API GetPixel récupère la couleur d'un point de coordonnées x et y. Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long 'hDC c'est le control qui contient l'image à modifier (de type "Bmp"). Dim x As Integer Dim y As Integer ' fonction qui supprime une couleur d'une image Public Sub SupCouleur(Picture As PictureBox, Couleur_Sup As Long) 'avec ces deux boucles for on parcoure tout les points de l'image For x = 0 To Picture.ScaleWidth For y = 0 To Picture.ScaleHeight ' Ici on récupère la couleur du point de coordonnées x et y couleur_point = GetPixel(Picture.hDC, x, y) ' si c'est la couleur à supprimer alors on modifie ce point If couleur_point = Couleur_Sup Then ' appel du l'API SetPixelV pour modifier le point de coordonnées X et Y avec la 'couleur Blanche SetPixelV Picture.hDC, x, y, vbWhite 'On peut changer la couleur à remplacer par des autres couleur (comme vbred pour 'remplacer le point en rouge ....)(SetPixelV Picture.hDC, x, y, vbred). Aussi vous 'pouvez utilisez des autres méthodes,' par exemple pour supprimer le point: 'SetPixelV Picture.hDC, x, y, (couleur_point - vbred)' mais dans ce cas faut enlever la 'condition if (If couleur_point = Couleur_Sup Then) ;) End If Next y Next x End Sub ' a mettre dans un form Private Sub Command1_Click(Index As Integer) ' vous pouvez ajouter des autres couleurs à supprimer ou à modifier en remplaçant 'le code de la couleur par un autre (ici vbred, vbblack..) ou bien directement le code de la couleur '(ex: SupCouleur Picture1, 255 ' pour supprimer le rouge).Vous pouvez aussi 'utilisez des autres méthodes d'appel de fonction, ici très simple avec select case Select Case Index Case 0 ' Bouton Rouge SupCouleur Picture1, vbRed Case 1 ' Bouton vert SupCouleur Picture1, vbGreen Case 2 ' Bouton Bleue SupCouleur Picture1, vbBlue Case 3 ' Bouton Jaune SupCouleur Picture1, vbYellow Case Else ' Bouton Noir SupCouleur Picture1, vbBlack End Select End Sub '********************** Private Sub Form_Load() ' Charger l'image dans Picturebox Picture1.Picture = LoadPicture(App.Path & "\couleurs.bmp") ' Changer la propriété ScaleMode de l'image en Pixel Picture1.ScaleMode = 3 End Sub
J'ai essayé de copier ce code sous access mais j'ai quelques erreurs.
Si quelqu'un peu m'aider, mon objectif est simple:
J'ai une image de base avec des surfaces de couleurs différentes (comme l'image de ce projet)
J'ai un fichier texte avec les données ratachées à l'image. A savoir : chaque surface a un identifiant + un code couleur + la nouvelle couleur.
Ce que je veux, c'est, sous access, lire dans le txt et mémoriser ce qu'il y a à changer, puis regarder chaque pixel de mon image et voir s'il doit être changé. Une fois sela fait, il faut sauvegarder l'image bmp ou autre.
Tout ceci ne doit pas être visible, ce n'aest qu'après que je vai chargé l'image finale.
Voici un début de code :
Pour lire le txt :
Private Sub macro_map()
Dim dbs As Database
Dim rst1 As Recordset
Dim rep_base As String
Dim oFSO As Scripting.FileSystemObject
Dim oFl As Scripting.File
Dim oTxt As Scripting.TextStream
Dim i, j As Integer
Dim machaine, tablo(344, 2) As String
Dim lhProcess As Long
Dim lProcessID As Long
Dim lpExitCode As Long
Set oFSO = New Scripting.FileSystemObject
Set dbs = CurrentDb
Set rst1 = dbs.OpenRecordset("SELECT * FROM CONFIG WHERE CONFIG.TypeDonnee='Répertoire contenant les images';")
If Not (rst1.EOF) Then
rst1.MoveFirst
rep_base = rst1!Donnee
rst1.Close
'******************** li dans le fichier data.src *********************
Set oFl = oFSO.GetFile(rep_base & "\data\data.src")
Set oTxt = oFl.OpenAsTextStream(ForReading)
i = 0
With oTxt
While (Not .AtEndOfStream And i < 344)
i = i + 1
machaine = .ReadLine
tablo(i, 1) = Left(machaine, InStr(machaine, vbTab) - 1)
tablo(i, 2) = Right(machaine, Len(machaine) - InStr(machaine, vbTab))
Wend
j = i
End With
oTxt.Close
Set oFl = Nothing
'******************** lance la requête (cherchez pas à la comprendre je vous donne le fichier résultat juste après) ******************************** Set rst1 dbs.OpenRecordset("select insee, ville, d_min FROM (SELECT COMMUNE.insee, COMMUNE.Nom AS Ville, MIN(DISTANCE.km+CATEGCS.DistSup) AS D_Min FROM (FAMTE INNER JOIN TYPENGIN ON FAMTE.Libelle TYPENGIN.Famille) INNER JOIN (((CATEGCS INNER JOIN CS ON CATEGCS.ProVol = CS.ProVol) INNER JOIN ARME ON CS.Nom = ARME.ArmeCS) INNER JOIN (COMMUNE INNER JOIN DISTANCE ON COMMUNE.INSEE = DISTANCE.DistCOM) ON CS.Nom = DISTANCE.DistCS) ON TYPENGIN.Libelle = ARME.ArmeTE WHERE (((FAMTE.Libelle) = 'FPT')) GROUP BY COMMUNE.insee,COMMUNE.Nom ORDER BY COMMUNE.Nom) ;")
Set oFl = oFSO.GetFile(rep_base & "\data\carte.src")
Set oTxt = oFl.OpenAsTextStream(ForWriting)
rst1.MoveFirst
i = 0
'******************** écris dans le fichier carte.src ******************
oTxt.WriteLine "#" & vbTab & "iden" & vbTab & "commune" & vbTab & "nouvelle_couleur"
While Not (rst1.EOF)
i = i + 1
With oTxt
If (rst1!D_Min <= 10) Then
.WriteLine i & vbTab & rst1!INSEE & vbTab & rst1!Ville & vbTab & "FF7700"
Else
If (rst1!D_Min <= 20) Then
.WriteLine i & vbTab & rst1!INSEE & vbTab & rst1!Ville & vbTab & "77FF00"
Else
If (rst1!D_Min <= 30) Then
.WriteLine i & vbTab & rst1!INSEE & vbTab & rst1!Ville & vbTab & "00FF77"
Else
If (rst1!D_Min <= 45) Then
.WriteLine i & vbTab & rst1!INSEE & vbTab & rst1!Ville & vbTab & "0077FF"
Else
.WriteLine i & vbTab & rst1!INSEE & vbTab & rst1!Ville & vbTab & "000000"
End If
End If
End If
End If
End With
rst1.MoveNext
Wend
oTxt.Close
Set oFSO = Nothing
rst1.Close
End If
dbs.Close
' coller également le code de modification de l'image ici
End Sub
Voici les 2 fichiers txt :
-data.src :
iden couleur
34135001 FF0000
34121002 00FF00
34101003 0000FF
34130004 00FFFF
34313005 FFFF00
34127006 FF00FF
34130007 FFFFFF
34135009 000000
...
-carte.src:
# iden commune nouvelle_couleur
1 34135001 ABEILHAN 77FF00
2 34121002 ADISSAN FF7700
3 34101003 AGDE FF7700
4 34130004 AGEL 00FF77
5 34313005 AGONES 77FF00
6 34127006 AIGNE 77FF00
7 34130007 AIGUES VIVES 77FF00
8 34135009 ALIGNAN DU VENT 77FF00
...
Et voici le code pour changer les pixels mais qui ne marche pas :
'module1
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Byte
'partie à coller dans form1
Dim x, y, z As Integer
For x = 0 To Image7.ImageWidth
For y = 0 To Image7.ImageHeight
couleur_point = GetPixel(GetDC(0), x, y)
For z = 1 To 343
If couleur_point = tablo(z, 1) Then
SetPixel mon_image.Handle, x, y, vbYellow '(en jaune pour l'instant mais sera remplacé par la nouvelle couleur : carte.src)
End If
Next z
Next y
Next x
Me.Refresh
End Sub
Voilà cela ne marche pas ... quelqu'un peut m'aider?
Merci
Mise à part, c'est simple et efficace!
good!
et effectivement, c'es ça la reponse que j'arrive a trouver(autoredraw), sinon, il y a des autres solution un peu compliquer avec les api, ou bien tu ne laisse jamais ta fenetre quitte l'ecran, avec simple code en utilisant les proprietes left,top,width,height et screen .....
merci pour cette remarque, je suis en train de programmer un truc avec setpixel et getpixel, mais pour colorer les bouton (command)donc ce probleme sera plus compliquer a resoudre, surtout sont creer dynamiquement :(
a++++
davidauche
Merci quand même :-)
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.