Colors in a picture box (vb6)
Alejandro Carrascal
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!
MikeD
"Alejandro Carrascal" <alc...@hotmail.com> wrote in message
news:43d2c...@x-privat.org...
I can't help you, but I just HAVE to know why on earth you would need to
LIST all the colors used in the picture? This could be in the thousands.
Sure, any decent paint or drawing program can capture a color, but listing
EVERY one of them?
I don't much much about picture formats, but if the picture is even just 800
x 600, checking 480,000 pixels, I'd think, would be quite time-consuming.
Now throw in the possibility of there even being just 500 hundred different
colors used. When you get to the 480,000th pixel, you'd be checking its
color against at least 499 other colors. I just can't see this being
feasible.
--
Mike
Microsoft MVP Visual Basic
Ivar
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" <alc...@hotmail.com> wrote in message
news:43d2c...@x-privat.org...
Tom Esh
wrote:
>
>I don't much much about picture formats, but if the picture is even just 800
>x 600, checking 480,000 pixels, I'd think, would be quite time-consuming.
>Now throw in the possibility of there even being just 500 hundred different
>colors used. When you get to the 480,000th pixel, you'd be checking its
>color against at least 499 other colors. I just can't see this being
>feasible.
I dunno. I use an old version of PSP (5.0) and it will count and
report # of colors used on a much larger 32-bit image in well under a
second. No doubt highly optimized code, but with 3ghz+ CPUs being the
norm these days...
-Tom
MVP - Visual Basic
(please post replies to the newsgroup)
Lance Wynn
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" <alc...@hotmail.com> wrote in message
news:43d2c...@x-privat.org...
Mike D Sutton
Have a look at the Octree colourspace quantisation methods, it uses a tree
structure to count colours and frequency as is usually used to find optimal
palettes however if you don't prune the leaf nodes at each level you'll get
a colour count instead.
Hope this helps,
Mike
- Microsoft Visual Basic MVP -
E-Mail: ED...@mvps.org
WWW: Http://EDais.mvps.org/
Mike Williams
news:QdBAf.7633$OI3....@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 Williams" <Mi...@WhiskyAndCoke.com> wrote in message
news:OZMLq50...@TK2MSFTNGP14.phx.gbl...
. . . by the way, I forgot to mention the fact that a bitmap that you load
into a VB picture box or into a StdPicture object or anyhting of a similar
nature will be an exact copy of the original on disk *only* if your computer
is running at full colour depth. So if you want your code to work properly
on all machines (including those running at 16 bit colour depth or less)
then you need to instead get the original bitmap into a DIB structure
(device independent bitmap). You can use pretty much the same code on a DIB
with very slight modification.
Mike
Mike Williams
news:OZMLq50...@TK2MSFTNGP14.phx.gbl...
. . . here's a slight modification of my earlier code, which is a bit faster
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
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
Fatih Argun
doesn't require setting the autoredraw, autosize or scalemode properties.
thanks for your information...
------------------------------------------------------------------
SourceWidth = ConvertPixelHimetric(Picture1.Picture.Width, LOGPIXELSX)
SourceHeight = ConvertPixelHimetric(Picture1.Picture.Height, LOGPIXELSY)
lret = GetDIBits(Picture1.hdc, Picture1.Picture, _
0, SourceHeight, SourceArray(1, 1), bmapinfo, _
DIB_RGB_COLORS)
--------------------------------------------------------------
'source: Mike D Sutton
(http://edais.mvps.org/Code/Libraries/Graphics/modOLEPicture.html)
Private Enum LOGPIXELS
LOGPIXELSX = 88
LOGPIXELSY = 90
End Enum
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" (ByVal
lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As
String, ByRef lpInitData As Any) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hdc As Long,
ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long,
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Function ConvertPixelHimetric(ByVal inValue As Long, GDCFlag As
LOGPIXELS) As Long
Dim TempIC As Long
Const HimetricInch As Long = 2540
TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If (TempIC) Then
ConvertPixelHimetric = MulDiv(inValue, GetDeviceCaps(TempIC,
GDCFlag), HimetricInch)
DeleteDC TempIC
End If
End Function
Mike Williams
news:ehjbF7C...@tk2msftngp13.phx.gbl...
> the following style using Picture1.Picture instead of Picture1.Image
I'm not sure what you're getting at there? I did it that way because the
code is an extract from a program I had written to perform tasks other than
simply counting colours. In fact if you want to minimise your use of
resources then you don't need a picture box at all, which makes me wonder
why you continued to use one in your own super duper modification that you
appear to be holding out as being is so much better than mine!
> . . . and doesn't require setting the autoredraw,
> autosize or scalemode properties.
> Private Function ConvertPixelHimetric(ByVal inValue As Long, _
GDCFlag As LOGPIXELS) As Long
> Dim TempIC As Long
> Const HimetricInch As Long = 2540
> TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
> If (TempIC) Then
> ConvertPixelHimetric = MulDiv(inValue, GetDeviceCaps . . . etc, etc . . .
Why have you used all that code in the ConvertPixelHimetric subroutine just
to get the size of a picture that is already in the picture property of a
picture box? Surely you would only need that if you didn't already have a
nice picture object to work with. If you've got a picture box (which you
have in the code you posted) then you can more simply do:
SourceWidth = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
Mike
Mike Williams
news:OZMLq50...@TK2MSFTNGP14.phx.gbl...
Okay. For anyone interested here's my code to count the colours in a 24 bit
bmp picture, modified so as to use individual bits as flags (rather than
Bytes). There is still some optimisation that can be doneof course. The
modification results in the code using only 2 Mb as the "pixel colour data
store" instead of the previous 16 Mb, which of course can only be a good
thing. It needs a bit more logic than the "byte" or "long" data store
methods (naturally) but no extra overall time is required to perform that
extra logic because an equivalent amout of time is saved by requiring the
code to deal with a much smaller overall byte size of data. The code takes a
bit longer when run in the IDE of course (because of the additional
"interpreter time" required) but it runs at about the same speed as the
original when run as a compiled exe (with the same array bounds and integer
overflow advanced optimisations as the original). So, overall a similar fast
speed combined with a very large saving in memory used. By the way (for
Fatih Argun and an yone else who may be interested) I'm still using a VB
autoredraw picture box because I'm really not interested at the moment in
anything else other than improving the "count the colours" routine itelf,
and I am perfectly capable of getting rid of the picture box if and when I
should choose to do so ;-)
Mike
Private clrs(0 To 2 ^ 21 - 1) As Byte
Private TwoToThePowerOf(0 To 7) As Byte
Private Sub Form_Load()
Dim n As Long
For n = 0 To 7
TwoToThePowerOf(n) = 2 ^ n
Next n
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, allclrsByte As Long, bitmask As Byte
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)
Dim yyy As Long
For y = 1 To SourceHeight
For x = 1 To SourceWidth
p = SourceArray(x, y)
allclrsByte = p \ 8
bitmask = TwoToThePowerOf(7 - p Mod 8)
If (clrs(allclrsByte) And bitmask) = 0 Then
used = used + 1
clrs(allclrsByte) = clrs(allclrsByte) Or bitmask
End If
Next x
Next y
t2 = Timer
Caption = yyy
s1 = Format(t2 - t1, "0.0") & " seconds. Colours used = " _
& Format(used)
MsgBox s1
End Sub
Fatih Argun
> interested at the moment in anything else other than improving the "count
> the colours"
but it must adapt and work with every programs, doesn't it?
> Why have you used all that code in the ConvertPixelHimetric subroutine
> just to get the size of a picture that is already in the picture property
> of a picture box?
because of this techique may be use in an activex dll and i don't know
another way in that situation.
- i did try this technique with 32 bit bitmap that it has alpha channel then
runtime error 9 occurs (subscript out of range)
(photoshop cs2 --> (alpha) channel options --> color indicates = masked
areas)
it must fast but it must strong (safe) too :))
note: i'm not a professional programmer, especially about graphics and sory
for my bad english, i hope you understand me
regards....
Mike Williams
> but it must adapt and work with every programs, doesn't it?
All code will adapt and work with every program, if somebody takes the time
to adapt it and does it properly. Perhaps you don't fully understand the
purpose of these newsgroups Fatima. People post questions here in the hope
of receiving an answer to their specific question and other people write and
post answers that may help them. The people who ask the questions are not
paying for someone to write full blown applications or ActiveX dlls for
them, and they don't expect anyone to do that for them. Also, the people
providing the answers generally have neither the time nor the inclination to
provide the code for a full blown applications in their answers. They
generally provide enough information and code to help out the user in such a
way that the user can understand what is going on and end up being in a
position so that they can themselves adapt it to their own specific needs.
> because of this techique may be use in an activex dll
> and i don't know another way in that situation
> it must fast but it must strong (safe) too :))
But the original poster did not ask for code for an ActiveX dll. In fact he
very specifically said, "I have an image in a PictureBox. I would like to
create a list with all the colors shown". Which part of that statement do
you not understand? The OP already has a VB picture box on a VB Form and he
already has an image in it, and so I posted some code that he couyld paste
into his Form to allow him to count the colours in that image. Is that not
what I should have done? Perhaps you can do better Fatima.
By the way, in playing around with this stuff I've just written some code
that will load a 24 bit full colour 800 x 600 pixel bmp file from disk and
count the number of colours it contains and it will do all this (both load
the bitmap and count the colours) in less than 50 milliseconds (less than
one twentieth of a second). Presumably, with all you expert knowledge in
these things Fatima, you'll be able to come up with something faster. Post
your code when you've done so.
Mike
Alejandro Carrascal
It actually does not take that long to read each pixel as mentioned by Tom
Esh using PSP. The images I am using are mainly technical cross plots, not
photos with millions of colors. A graph obtained by scanning a technical
article with a crossplot of Pressure vs Temperature data points is an
example. I would not expect more than few dozen colors.
Regards,
Alejandro
"MikeD" <nob...@nowhere.edu> wrote in message
news:ePVJV5uH...@TK2MSFTNGP11.phx.gbl...
Alejandro Carrascal
try.
Best regards,
Alejandro
"Mike Williams" <Mi...@WhiskyAndCoke.com> wrote in message
news:uAcWjS$HGHA...@TK2MSFTNGP15.phx.gbl...
Alejandro Carrascal
Your code is superfast!!
One simple question (from a simple user..). To test the code I loaded a 16
(4 BitsPerPixel) color BMP and I created an array of 16 picture boxes. I
wanted each picture box in the array to display one of the distinct colors
found with your code. I added the following line to your code just before
the color counter increments:
Picture2(used).BackColor = p
However, the colors I get do not match the colors in the original image.
What am I missing?
Thanks again,
Alejandro
"Mike Williams" <Mi...@WhiskyAndCoke.com> wrote in message
news:evTDheGI...@tk2msftngp13.phx.gbl...
Mike Williams
> I added the following line to your code just before the color counter
> increments Picture2(used).BackColor = p
> However, the colors I get do not match the colors
> in the original image. What am I missing?
The GetDIBits API function is usually used to get the colours four bytes per
pixel into an array of RGBQUADs, enabling you to deal with the red, green
and blue components individually. The RGBQUADs look like this:
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
However, in order to speed up the "analyse" code I instead got them into a
simple array of Longs. The individual colour bytes of course will end up in
the bytes of the Long in the order shown above for the RGBQUAD. This is the
reverse of a standard "Long colour", where the red and the blue bytes swap
positions from those shown above. So, you can either change the code to use
RGBQUADs instead of Longs for the SourceArray array (in which case you will
need to modify the code that checks each colour to see if it is already in
the list) or you can instead just "swap the bytes over" whenever you need to
do so. There are various different ways of doing this. In your specific case
for example you could use something like this:
*** in the declarations ***
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type mylong
clr As Long
End Type
Private cbytes As RGBQUAD
Private clong As mylong
***** in your code *****
clong.clr = SourceArray(1, 1)
LSet cbytes = clong ' transfer byte data from one UDT to another
Picture2.BackColor = RGB(cbytes.rgbRed, cbytes.rgbGreen, cbytes.rgbBlue)
Mike