Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Hi,
i want algorithm VB or VBA to get all XY Coordinates of picture pixels colors in correct order to trace the contours edges to plot a vector shape of original picture.
i am able to get the coords of neighbors pixels but not in correct order.
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Hi, Arnoutdv,
thank you for your atention.
my algorithm to scan pixels is (but i not able to get the correct ordering of pixels to draw a shape):
Code:
Private Sub GetPixels(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
PixelCount = 0
For X = 0 To Picture1.ScaleWidth - 1
For Y = 0 To Picture1.ScaleHeight - 1
TempColor = GetPixel(Picture1.hdc, X, Y)
If TempColor <> BGColor Then
ReDim Preserve PixelStack(PixelCount)
PixelStack(PixelCount).X = X
PixelStack(PixelCount).Y = Y
PixelStack(PixelCount).Color = TempColor
PixelCount = PixelCount + 1
End If
Next
Next
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
each pixel (point) of image have a x,y coordinates, but the scan algorithm gives the coords by horizontal line of picture, line after line, but not in same contour arrange to i plot a autoshape vectorial image with Polyline function.
vectorization process.
i am not want other tools, i am need only the algorithm to get the correct arrange of coords of pixels.
thanks.
edit: i look other edge detections algorithms but not know arrange the coords.
Last edited by xman2000; May 18th, 2017 at 07:54 AM.
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
my problem: this code uses 3 picturebox and i not sucessful to work, i need simplify this code to uses only 1 or 2 picturebox and choose the color values more simply.
Another part of previous code, full code by Cyborg here:
Private Sub DrawOutline(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
Picture1.Cls
For X = 0 To Picture1.ScaleWidth - 1
For Y = 0 To Picture1.ScaleHeight - 1
If GetPixel(Picture2.hdc, X, Y) = BGColor Then
If GetPixel(Picture2.hdc, X + 1, Y) <> BGColor Or GetPixel(Picture2.hdc, X - 1, Y) <> BGColor Then
If X <> Picture1.ScaleWidth - 1 And X <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
If GetPixel(Picture2.hdc, X, Y + 1) <> BGColor Or GetPixel(Picture2.hdc, X, Y - 1) <> BGColor Then
If Y <> Picture1.ScaleHeight - 1 And Y <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
End If
Next
Next
Picture1.Refresh
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
full source code of Form1.frm
Code:
VERSION 5.00
Begin VB.Form Form1
Caption = "Outline by Cyborg - daniel_hansson@telia.com"
ClientHeight = 8655
ClientLeft = 60
ClientTop = 345
ClientWidth = 6825
LinkTopic = "Form1"
ScaleHeight = 8655
ScaleWidth = 6825
StartUpPosition = 1 'CenterOwner
Begin VB.OptionButton Option2
Caption = "Store object info (click gradient pic to redraw)"
Height = 975
Left = 4440
TabIndex = 4
Top = 4800
Width = 1575
End
Begin VB.OptionButton Option1
Caption = "Draw Outlines"
Height = 495
Left = 4440
TabIndex = 3
Top = 4320
Value = -1 'True
Width = 1575
End
Begin VB.PictureBox Picture3
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 4050
Left = 120
Picture = "Form1.frx":0000
ScaleHeight = 270
ScaleMode = 3 'Pixel
ScaleWidth = 276
TabIndex = 2
Top = 4200
Width = 4140
End
Begin VB.PictureBox Picture2
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 4050
Left = 4440
Picture = "Form1.frx":3698A
ScaleHeight = 270
ScaleMode = 3 'Pixel
ScaleWidth = 276
TabIndex = 1
Top = 120
Width = 4140
Visible = 0 'False
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
Height = 4050
Left = 120
Picture = "Form1.frx":6D314
ScaleHeight = 270
ScaleMode = 3 'Pixel
ScaleWidth = 276
TabIndex = 0
Top = 120
Width = 4140
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Type PixelStackType
X As Single
Y As Single
Color As Long
End Type
Dim PixelStack() As PixelStackType
Dim PixelCount As Double
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Caption = "Working..."
If Option1.Value = True Then
DrawOutline GetPixel(Picture1.hdc, X, Y)
Picture1.Picture = Picture1.Image
Picture2.Picture = Picture1.Image
Else
GetPixels GetPixel(Picture1.hdc, X, Y)
End If
Me.Caption = "Done!"
End Sub
Private Sub DrawOutline(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
Picture1.Cls
For X = 0 To Picture1.ScaleWidth - 1
For Y = 0 To Picture1.ScaleHeight - 1
If GetPixel(Picture2.hdc, X, Y) = BGColor Then
If GetPixel(Picture2.hdc, X + 1, Y) <> BGColor Or GetPixel(Picture2.hdc, X - 1, Y) <> BGColor Then
If X <> Picture1.ScaleWidth - 1 And X <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
If GetPixel(Picture2.hdc, X, Y + 1) <> BGColor Or GetPixel(Picture2.hdc, X, Y - 1) <> BGColor Then
If Y <> Picture1.ScaleHeight - 1 And Y <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
End If
Next
Next
Picture1.Refresh
End Sub
Private Sub GetPixels(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
PixelCount = 0
For X = 0 To Picture1.ScaleWidth - 1
For Y = 0 To Picture1.ScaleHeight - 1
TempColor = GetPixel(Picture1.hdc, X, Y)
If TempColor <> BGColor Then
ReDim Preserve PixelStack(PixelCount)
PixelStack(PixelCount).X = X
PixelStack(PixelCount).Y = Y
PixelStack(PixelCount).Color = TempColor
PixelCount = PixelCount + 1
End If
Next
Next
End Sub
Private Sub RedrawPixels(X As Single, Y As Single)
Dim i As Long
For i = 0 To PixelCount - 1
SetPixelV Picture3.hdc, PixelStack(i).X + X - Picture3.ScaleWidth / 2, PixelStack(i).Y + Y - Picture3.ScaleHeight / 2, PixelStack(i).Color
Next
End Sub
Private Sub Picture3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Picture3.Cls
RedrawPixels X, Y
Picture3.Refresh
End If
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
You don't need the 3rd picture box, that's was just fore some other demo.
The 2nd picturebox is a copy from the 1st to always work on a clean unmodified image.
Code for 2 pictureboxes (1=main, 2=backup)
Code:
Option Explicit
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Type PixelStackType
X As Single
Y As Single
Color As Long
End Type
Dim PixelStack() As PixelStackType
Dim PixelCount As Double
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Caption = "Working..."
DrawOutline GetPixel(Picture1.hdc, X, Y)
Picture1.Picture = Picture1.Image
Picture2.Picture = Picture1.Image
Me.Caption = "Done!"
End Sub
Private Sub DrawOutline(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
Picture1.Cls
For X = 0 To Picture1.ScaleWidth - 1
For Y = 0 To Picture1.ScaleHeight - 1
If GetPixel(Picture2.hdc, X, Y) = BGColor Then
If GetPixel(Picture2.hdc, X + 1, Y) <> BGColor Or GetPixel(Picture2.hdc, X - 1, Y) <> BGColor Then
If X <> Picture1.ScaleWidth - 1 And X <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
If GetPixel(Picture2.hdc, X, Y + 1) <> BGColor Or GetPixel(Picture2.hdc, X, Y - 1) <> BGColor Then
If Y <> Picture1.ScaleHeight - 1 And Y <> 0 Then
SetPixelV Picture1.hdc, X, Y, vbBlack
End If
End If
End If
Next
Next
Picture1.Refresh
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Arnoutdv , thanks, i will test your code for some hous ( i am very slow).
but notice i not trully want trace the contour color over the picture only, i want get the coords of this outline.
i think i grab the coords instead this line "SetPixelV Picture1.hdc, X, Y, vbBlack"
after, i will plot the shape with this coords.
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Updated the sample by Cyborg to work with only 2 images.
The input image on which you click to trace a color
The output image on which the outline is drawn.
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Huh?
Did you try the program?
Partial source code:
Code:
Private Sub GetPixels(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
PixelCount = 0
For X = 0 To picOutline.ScaleWidth - 1
For Y = 0 To picOutline.ScaleHeight - 1
TempColor = GetPixel(picOutline.hdc, X, Y)
If TempColor <> BGColor Then
ReDim Preserve PixelStack(PixelCount)
PixelStack(PixelCount).X = X
PixelStack(PixelCount).Y = Y
PixelStack(PixelCount).Color = TempColor
PixelCount = PixelCount + 1
End If
Next
Next
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Hi, Arnoutdv,
I'm trying to adapt your code but I did not understand Where it is used the "Getpixel(s)"
in original code the function is called (GetPixel(s) GetPixel):
Code:
GetPixels GetPixel(hdc, x, y)
I will continue testing, I have not finished because Excel is more complicated to do.
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Sorry, but did you even read the source code?
If you click on the main image it retrieves the current color on the mouse-position using GetPixel.
Then this color is passed to DrawOutline, GetPixels() is not even used anymore
Code:
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As _
Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Type PixelStackType
X As Single
Y As Single
Color As Long
End Type
Dim PixelStack() As PixelStackType
Dim PixelCount As Double
Private Sub Form_Load()
picOutline.AutoRedraw = True
picOutline.BackColor = vbWhite
End Sub
Private Sub picImage_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Caption = "Working..."
DrawOutline GetPixel(picImage.hdc, X, Y)
Me.Caption = "Done!"
End Sub
Private Sub DrawOutline(BGColor As Long)
Dim X As Single
Dim Y As Single
Dim TempColor As Long
'picOutline.Cls
For X = 0 To picOutline.ScaleWidth - 1
For Y = 0 To picOutline.ScaleHeight - 1
If GetPixel(picImage.hdc, X, Y) = BGColor Then
If GetPixel(picImage.hdc, X + 1, Y) <> BGColor Or GetPixel(picImage.hdc, X - 1, Y) <> BGColor Then
If X <> picOutline.ScaleWidth - 1 And X <> 0 Then
SetPixelV picOutline.hdc, X, Y, vbBlack
End If
End If
If GetPixel(picImage.hdc, X, Y + 1) <> BGColor Or GetPixel(picImage.hdc, X, Y - 1) <> BGColor Then
If Y <> picOutline.ScaleHeight - 1 And Y <> 0 Then
SetPixelV picOutline.hdc, X, Y, vbBlack
End If
End If
End If
Next
Next
picOutline.Refresh
End Sub
Private Sub picOutline_Click()
picOutline.Cls
End Sub
Re: Image PIxel Color Coordinates Correct Orderind XY To Plot Shape ?
Arnoutdv, thank you very, very mutch!
i still testing, but in Excel this is more complex, the colors on Getpixel at mouse pointer not get directly to 2 ImageBox at same procedure, and more Setpixel at same procedure, i need passes the values of a procedure to other procedure or put all code in same procedure.
i have all thing to make this work, but i will have more time to check if work.
and my ultimate goal is rearrange the coordinates of x,y.
i know this website, if you know some detail of this samples, file tell to me.
i need now to make "Arnoutdv" code to work :
"I want pass the coords X,Y mouse Pointer and color values of ImageControl to Other Procedure Not im same ImageControl."
"i able to get the values, but not retrieve on memory and pass to other procedure."