Microsoft Visual Basic: Colors in a picture box (vb6)

Reading each Pixel colour is the easy and quick part, Even with a picture
the size of the screen I expect this could be done in less that a second.
Storing the list of colours in an array of longs would be quite quick to,
Still less that a second.
Finding the destinct colours?
This is where you go and hire a DVD and watch it while the processing is
done.
It's possible, but would take a very very long time unless the picture is
very small.

Ivar
"Alejandro Carrascal" <alcasa...hotmail.com> wrote in message
news:43d2cb25_3...x-privat.org...
> Hello,
> I have an image in a PictureBox. I would like to create a list with all
> the
> colors shown. I was thinking reading each pixel in the picture box and
> storing the list of colors I'm finding as I read. Is this the best way to
> find the distinct colors that are present in the image?
> Thank you!
>

I was able to get this to work like this (Probably not the best way, but it
works, and it is quite fast. My P4 2.8ghz can process an image with 500,000
+ pixels in about 15 seconds.): Just add a command button, 2 picture boxes,
and a progress bar to the form, and reference ADO If you put the individual
colors into an array, and sorted the array, you might even be able to get it
faster, ADO obviously has a good deal of overhead

Private Sub Command1_Click()
Dim i As Long
Dim X As Single
Dim Y As Single
Dim rsColors As Recordset
Dim currentPoint As Long
Dim tmpColor As Long
Dim colorArray() As Long

Set rsColors = New Recordset
rsColors.Fields.Append "Color", adBigInt

rsColors.Open
ReDim colorArray(Picture1.Picture.Width / Screen.TwipsPerPixelX *
Picture1.Picture.Height / Screen.TwipsPerPixelY)

ProgressBar1.Min = 0
ProgressBar1.Max = UBound(colorArray)

On Error Resume Next
For i = 1 To UBound(colorArray) + 1
X = (i Mod (Picture1.Picture.Width / Screen.TwipsPerPixelX)) - 1
Y = Int(i / (Picture1.Picture.Width / Screen.TwipsPerPixelX))

tmpColor = Picture1.Point(X, Y)
rsColors.AddNew
rsColors.Fields("Color") = tmpColor
If i Mod 100 = 0 Then
ProgressBar1.value = i
End If
'Debug.Print colorArray(i - 1)
Next
rsColors.Update

Picture2.ScaleMode = vbPixels
Dim lastColor As Long
lastColor = -1

rsColors.Sort = "Color"
Do Until rsColors.EOF
tmpColor = rsColors("Color")
If lastColor <> tmpColor Then
currentPoint = currentPoint + 1

X = currentPoint Mod Picture2.ScaleWidth
Y = Int(currentPoint / Picture2.ScaleWidth)

Picture2.PSet (X, Y), tmpColor
End If
rsColors.MoveNext
Loop

MsgBox "Image Contains " & rsColors.RecordCount & " Pixels, With " &
currentPoint & " Unique Colors."
End Sub

"Alejandro Carrascal" <alcasa...hotmail.com> wrote in message
news:43d2cb25_3...x-privat.org...
Hello,

I have an image in a PictureBox. I would like to create a list with all the
colors shown. I was thinking reading each pixel in the picture box and
storing the list of colors I'm finding as I read. Is this the best way to
find the distinct colors that are present in the image?

Thank you!

"Ivar" <ivar.ekstromer000...ntlworld.com> wrote in message
news:QdBAf.7633$OI3.7297...newsfe2-win.ntli.net...

> Finding the destinct colours? This is where you go and hire
>a DVD and watch it while the processing is done.

Actually you can do this sort of thing very quickly. There are a number of
different mehthods. One of the simplest (although not the fastest I suspect)
is shown below. The code currently reports the number of unique colours used
in the image, but that data telling you exactly what they are is also
gathered at the same time. All you need to do to display them in a ListBox
is to run through the "filled array" just once and any element that contains
a 1 indicates that the "element number" colour has been used in the image.

Here's the code. Paste it into a VB Form containing one Command Button abd
one Picture Box.

Mike

Option Explicit
Const BI_RGB = 0
Const DIB_RGB_COLORS = 0
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private SourceArray() As Long
Private SourceWidth As Long
Private SourceHeight As Long
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private bmapinfo As BITMAPINFO
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal hdc As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, _
ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, _
ByVal SrcY As Long, ByVal Scan As Long, _
ByVal NumScans As Long, Bits As Any, _
BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" _
Alias "RtlZeroMemory" _
(ByRef Destination As Any, ByVal Length As Long)
Private clrs() As Long

Private Sub Form_Load()
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
ReDim clrs(0 To &HFFFFFF)
Picture1.AutoSize = True
Picture1.Picture = LoadPicture("c:\tulips.bmp")
End Sub

Private Sub Command1_Click()
Dim lret As Long, t1 As Single, t2 As Single
Dim x As Long, y As Long, p As Long, used As Long
t1 = Timer
' Much of the time to perform the task is actually taken
' by the Redim (1 to &HFFFFFF) line. I've actually written
' a modified version of this code (using the individual bits
' in Longs to store the "colour used" flag instead of using
' a Long variable. (Can't remember why I didn't use Bytes
' now, but I'm sure it'll come back to me ;-)
' The "bits" method inceased the speed dramatically
' (because even though the "bit logic" tended to slow things
' down a little the speed advantage gained by using only one
' eighth of the memory for the array speeded it up enormously.
' Sadly, I lost that code when I got rid of my old computer
' and forgot to save it!). Maybe I'll write it againm one day!
ZeroMemory clrs(0), &HFFFFFF * 4 + 1 ' a bit faster than redim
SourceWidth = Picture1.ScaleWidth
SourceHeight = Picture1.ScaleHeight
With bmapinfo.bmiHeader
.biSize = 40
.biWidth = SourceWidth
.biHeight = SourceHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
ReDim SourceArray(1 To SourceWidth, 1 To SourceHeight)
lret = GetDIBits(Picture1.hdc, Picture1.Image, _
0, SourceHeight, SourceArray(1, 1), bmapinfo, _
DIB_RGB_COLORS)
' SourceArray now contains the pixel data, which you can
' transfer with Winsock (or do whatever else you want to
' do with it) before finally dumping it into another
' Picture Box of the same size.
' count the colours
For y = 1 To SourceHeight
For x = 1 To SourceWidth
p = SourceArray(x, y)
If clrs(p) = 0 Then
clrs(p) = 1
used = used + 1
End If
Next x
Next y
t2 = Timer
Caption = Format(t2 - t1, "0.0") & " seconds. Colours used = " _
& Format(used)
End Sub

"Mike Williams" <Mike...WhiskyAndCoke.com> wrote in message
news:OZMLq50HGHA.648...TK2MSFTNGP14.phx.gbl...

. . . here's a slight modification of my earlier code, which is a bit faste
r
and which removes one tiny error. For best results compile to native code
and set advanced optimizations to remove array bounds checks and integer
overflow checks. On my own machine it counts the unique colours in a 1600 x
1200 pixel bitmap in a bit less than half a second. I've still got to modify
it to use individual bits as flags, but that can wait for another day :-)

Mike

Option Explicit
Const BI_RGB = 0
Const DIB_RGB_COLORS = 0
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private SourceArray() As Long
Private SourceWidth As Long
Private SourceHeight As Long
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private bmapinfo As BITMAPINFO
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal hdc As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, _
ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, _
ByVal SrcY As Long, ByVal Scan As Long, _
ByVal NumScans As Long, Bits As Any, _
BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private clrs(0 To &HFFFFFF) As Byte

Private Sub Form_Load()
Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.Picture = LoadPicture("c:\dummypic.bmp")
End Sub

Private Sub Command1_Click()
Dim lret As Long, t1 As Single, t2 As Single
Dim x As Long, y As Long, p As Long, used As Long
Dim s1 As String
t1 = Timer
Erase clrs()
SourceWidth = Picture1.ScaleWidth
SourceHeight = Picture1.ScaleHeight
With bmapinfo.bmiHeader
.biSize = 40
.biWidth = SourceWidth
.biHeight = SourceHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
ReDim SourceArray(1 To SourceWidth, 1 To SourceHeight)
lret = GetDIBits(Picture1.hdc, Picture1.Image, _
0, SourceHeight, SourceArray(1, 1), bmapinfo, _
DIB_RGB_COLORS)
' count the colours
For y = 1 To SourceHeight
For x = 1 To SourceWidth
p = SourceArray(x, y)
If clrs(p) = 0 Then
clrs(p) = 1
used = used + 1
End If
Next x
Next y
t2 = Timer
s1 = Format(t2 - t1, "0.0") & " seconds. Colours used = " _
& Format(used)
MsgBox s1
End Sub