fastest way to iterate throught pixels of a bitmap?
Margo Hamilton
I'm trying to write a VB6-app that, in short, counts the unique colors of a
specified bitmap. Currently I'm loading a bitmap into a picturebox control,
then looping through the dimensions of that picturebox and calling the
.Point method. This works but is very slow.
Does anyone have ideas on a faster method? I'm not sure I understand all
the ins-n-outs of the stdPicture class, for example, but would that be
faster? How would you loop through the pixels of a stdPicture object?
I'd greatly appreciate any advice.
-- Margo
(ma...@on2morning.com)
Mark Wyman
http://home.rochester.rr.com/markyware
It has a great example on how to load a full-screen DIB into an array for
accessing individual colors of single pixels very quickly. You will have to
carve up the program a bit, but look for GetScreenDIB and SetDIBbits for the
most important calls. Note how I use a 3D array to break up the data into
R,G, and B bytes for easy access. I got lucky and stumbled on that one.
It's a little messy, but has some great, optimized routines for working with
DIBs in VB, like a semi-transparent line and lensing.
Good luck!
-Mark Wyman
Margo Hamilton <ma...@on2morning.com> wrote in message
news:uu0MRd$w#GA....@cppssbbsa02.microsoft.com...
David Winter
Margo Hamilton wrote in message ...
PixelManiac
Perhaps you'd want to try this....
1) Add a module to your project and place these in it....
Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
Long, ByVal y _ As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long)_ As Long
Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)_ As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Type BGRQuad
B As Byte
G As Byte
R As Byte
Reserved As Byte
End Type
2) In the General Declaration section of form1 put this..
Dim PixelArray() As BGRQuad, x%, y%
3) Link this sub to a menuitem or a command button...
Sub ScanPixelValues()
On Error Resume Next
Dim RGBLong As Long
Dim Startt As Single
Dim Endd As Single
Startt = Timer()
MousePointer = vbHourglass
x = 0
y = 0
SD = SaveDC(Picture1.hdc)
CCDC = CreateCompatibleDC(Picture1.hdc)
SOB = SelectObject(CCDC, Picture1.Picture)
ReDim PixelArray(0 To Picture1.ScaleWidth-1, 0 To
Picture1.ScaleHeight-1)
For y = 0 To Picture1.ScaleHeight-1
For x = 0 To Picture1.ScaleWidth-1
RGBLong& = GetPixel(CCDC, x, y)
PixelArray(x, y).B = RGBLong \ 65536
PixelArray(x, y).G = (RGBLong And &HFF00&) \ 256
PixelArray(x, y).R = RGBLong And &HFF&
Next x
Next y
RD& = RestoreDC(Picture1.hdc, SD)
DDC& = DeleteDC(CCDC)
Endd= Timer-Starrt
MousePointer = vbArrow
Me.caption=Endd
End Sub
4) Put a picture box on Form1 and set Scalemode to Pixels, Autoredraw to
True, Autosize to True.
You should have a bitmap loaded into Picture1 during design time.When
you execute the sub, it will quickly read all the longvalues of pixel
color and split them into RGB components and store them in the
PixelArray array. After that you can do whatever you want with this
information.
Hope this helps. If you have any problems with or queries regarding this
code, you can drop me a note at ad...@pc.jaring.my. Will be glad to
help.
Margo Hamilton
I've been trying some variations on the theme, all of which work,
technically speaking; but they all are just very slow. For example, to
"scan" through a 640x480 bitmap (either 8-bit 256-color or 1-bit, black and
white), took nearly 3 mintues (on my Gateway 400 with 128mb of RAM)!
I'm beginning to suspect that the idea of scanning a bitmap in a PictureBox
with GetPixel (or corresponding GetPoint VB-based method), is just too slow.
And, that the solution is to read the bitmap directly somehow. But, this
may be a bit more than I know how to tackle...
Ah well, back to the drawing board (pardon the pun).
Thank you again for your assistance.
-- Margo Hamilton
(ma...@on2morning.com)
Jon-Olav Hermansen
I have ben experimenting with some API calls to manipulate graphics.
Below is som sample code to get a bitmap from a picture box, manipulate it
to fade to black,
and draw the result back into a different picture box.
To use this code from a program, copy the code below into a class or a
bas-module, and do as follows.
Include two pictureboxes in a form, and set both to scalemode=3-Pixels
Put an image into one of them.
In a button or menuchoice (or whatever) write the following code :
'Fade to black
FadeToBlack [Picture1],[Picture2],10
'Fade from Black to image
FadeFromBlack [Picture1],[Picture2],10
Hope this helps.
Jon-Olav
Jon-Olav....@Cognit.no
[...............Start code........................]
' Past this code into a class or a bas file.
'
'
Global Const PIXEL As Integer = 3
Global Const DIB_RGB_COLORS As Long = 0
Declare Function GetDIBits24 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC As
Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As
Long, lpBits As Any, lpBI As BITMAPINFO_24, ByVal wUsage As Long) As Long
Declare Function SetDIBits Lib "GDI32" (ByVal hDC As Long, ByVal hBitmap As
Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI
As BITMAPINFO_24, ByVal wUsage As Long) As Long
Type BITMAPINFOHEADER '40 bytes
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
Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Type BITMAPINFO_24
bmiHeader As BITMAPINFOHEADER
End Type
Private SaveBits1() As Byte
Private SaveBits2() As Byte
Private Arraysize As Long
Private SaveBitmapInfo_24 As BITMAPINFO_24
Private SaveFileHeader As BITMAPFILEHEADER
Public Sub FadeFromBlack(Source As PictureBox, Destination As PictureBox,
Optional S As Integer = 10)
Dim fade As Long
Dim j As Long
Dim t As Integer
Dim fadeI As Integer
Dim t1 As Single
Dim t2 As Single
ReadData Source
For fade = 0 To 255 Step S
fadeI = 256 - fade
t1 = fadeI / 256
t2 = fade / 256
For j = 0 To Arraysize - 1
SaveBits2(j) = (0 * t1) + (SaveBits1(j) * t2)
Next j
DrawData Destination
Next fade
End Sub
Public Sub FadeToBlack(Source As PictureBox, Destination As PictureBox,
Optional S As Integer = 10)
Dim fade As Long
Dim j As Long
Dim t As Integer
Dim fadeI As Integer
Dim t1 As Single
Dim t2 As Single
ReadData Source
For fade = 0 To 255 Step S
fadeI = 256 - fade
t1 = fadeI / 256
t2 = fade / 256
For j = 0 To Arraysize - 1
SaveBits2(j) = (0 * t2) + (SaveBits1(j) * t1)
Next j
DrawData Destination
Next fade
End Sub
Public Sub ReadData(Pic As PictureBox)
Dim retval As Long
mvarHeight = Pic.ScaleHeight
mvarWidth = Pic.ScaleWidth
'size a buffer for the pixel data
Arraysize = (((Pic.ScaleWidth * 3 + 3) And &HFFFC) * Pic.ScaleHeight)
'(Pic.ScaleWidth * 3) * Pic.ScaleHeight '
ReDim SaveBits1(0 To Arraysize - 1)
ReDim SaveBits2(0 To Arraysize - 1)
'Header data
With SaveBitmapInfo_24.bmiHeader
.biSize = 40
.biWidth = Pic.ScaleWidth
.biHeight = Pic.ScaleHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = 0
.biClrUsed = 0
.biClrImportant = 0
.biSizeImage = Arraysize
End With
'get the bitmap
retval = GetDIBits24(Pic.hDC, Pic.Picture, 0,
SaveBitmapInfo_24.bmiHeader.biHeight, SaveBits1(0), SaveBitmapInfo_24,
DIB_RGB_COLORS)
End Sub
Public Sub DrawData(Pic As PictureBox)
Dim retval As Long
'Put the bitmap back.
retval = SetDIBits(Pic.hDC, Pic.Image.Handle, 0,
SaveBitmapInfo_24.bmiHeader.biHeight, SaveBits2(0), SaveBitmapInfo_24,
DIB_RGB_COLORS)
'If you have set Pic to autoredraw, you don't need to do this
Pic.Refresh
End Sub
[................. End Code ..........]
Jason Montgomery
talks about direct memory manipulation of bitmaps. This might be just what
your looking for. But I warn you...It is not for the weak stomached. Quite
complicated...I am still trying to grasp the concepts. :) Another problem
is this example only work for 256 color bitmaps. If I remember correctly,
they do have an example of how to do the same concepts (memory manipulation)
on a 16bit bitmap too. Anyway, give it a shot. Good luck.
http://www.advantage.co.nz/ur/vbmemory.htm
Hope this helps,
Jason
Margo Hamilton wrote in message ...
Stephen Smith
Margo,
I posted some VB code here (using the Point method) last week (I
think), and, somewhat abashed at your posting that this was too slow,
have since speeded it up 12-fold by using a 2 meg bitwise array of
booleans. Have a go with this one if you like.
Also note that if you compile it to an EXE (optimised for speed),
this speeds it up another 3-fold.
I hope this solves your problem,
Steve.
#If Win32 Then
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long,
ByVal X As Long, ByVal Y As Long) As Long
#Else
Private Declare Function GetPixel Lib "GDI" (ByVal hDC As Integer,
ByVal X As Integer, ByVal Y As Integer) As Long
#End If
Public Function image_CountColours(ByRef PIC As PictureBox) As Long
' counts the number of colours in a picture
' (function returns 0 if error or if PIC dimensions are 0x0)
' NOTES:
' This allows up to 16 million colours, but needs 2 meg free memory.
' With over about 50 (?) colours in the picture, this method
becomes increasingly faster cf. the non-array version.
' To speed this up, ensure the picturebox is autosized to the picture.
' Overall, this is 12 times faster than the old version of the
function, which scanned an array.
Dim i As Long
Dim AutoRedrawPrev As Boolean, ScaleModePrev As Integer,
PicScaleHeight As Long
Dim X As Long, Y As Long, Col As Long, PrevCol As Long
Dim Counter As Long
Dim ErrNumber As Long, ErrDescr As String
#If Win32 Then
Dim PicHDC As Long
#Else
Dim PicHDC As Integer
#End If
' ColorsFound is a 2 meg bitwise array of 1's and 0's;
' note that making it static (to avoid the time overheads in
allocating the memory) doesn't speed up the function much,
' and gives you problems releasing the memory.
Const MaxColValue As Long = 16777216
Dim ColorsFound(0 To MaxColValue / 8 - 1) As Byte
Static flag_Initialised As Boolean, BitMultipliers(0 To 7) As Byte
On Error GoTo goto_Error
' for speed, pre-initialise the bit multipliers
If Not flag_Initialised Then
For i = 0 To 7
BitMultipliers(i) = 2 ^ i
Next
flag_Initialised = True
End If
' store & set properties
AutoRedrawPrev = PIC.AutoRedraw
PIC.AutoRedraw = True
ScaleModePrev = PIC.ScaleMode
PIC.ScaleMode = vbPixels
' for speed, take all constants out of the loop
PrevCol = -1
PicHDC = PIC.hDC
PicScaleHeight = PIC.ScaleHeight
For X = 0 To PIC.ScaleWidth - 1
For Y = 0 To PicScaleHeight - 1 ' (taking this property outside
the loop gains another 10-20% in speed)
' for speed, ignore pixels the same colour as the previous pixel
' (NB - using GetPixel speeds up the whole function 3.5
times compared with using the Point method)
Col = GetPixel(PicHDC, X, Y)
If Col <> PrevCol Then
' add new color if necessary
If (ColorsFound(Col \ 8) And BitMultipliers(Col Mod
8)) = 0 Then
ColorsFound(Col \ 8) = ColorsFound(Col \ 8) Or
BitMultipliers(Col Mod 8)
Counter = Counter + 1
' (not updating the display here gains another
10% in speed)
End If
PrevCol = Col
End If
Next Y
Next X
image_CountColours = Counter
goto_Error:
ErrNumber = Err.Number
ErrDescr = Err.Description
' restore properties
PIC.ScaleMode = ScaleModePrev
PIC.AutoRedraw = AutoRedrawPrev
' offer error message
Select Case ErrNumber
Case 0 ' (all OK)
Case 7: MsgBox "Counting colours - insufficient memory for the 2
meg temporary array..."
Case 9: MsgBox "Counting colours - there are more than 16 million
colours in this picture type..."
Case Else: MsgBox "Unexpected error counting colours -" & vbCrLf
& ErrDescr & "..."
End Select
End Function
Margo Hamilton
mentioned something I hadn't considered (to my own chagrin, here). I had
not yet compiled the app to an EXE, but was just running it (with Full
Compile) through the IDE. I hope that speeds things up!
Thanks again. There have been so many helpful folks on this.
-- Margo
Stephen Smith wrote in message
<199907081...@SpamZapperZetnet.Co.Uk>...
Richard Mason
<ma...@on2morning.com> writes
>I'm beginning to suspect that the idea of scanning a bitmap in a PictureBox
>with GetPixel (or corresponding GetPoint VB-based method), is just too slow.
>And, that the solution is to read the bitmap directly somehow. But, this
>may be a bit more than I know how to tackle...
Try this:
Type BITMAP '24 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Type BITMAPINFOHEADER '40 bytes
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
Type DIBSECTION
dsBm As BITMAP
dsBmih As BITMAPINFOHEADER
dsBitfields(3) As Long
dshSection As Long
dsOffset As Long
End Type
Public Const DIB_PAL_COLORS = 1&
Public Const IMAGE_BITMAP = 0&
Public Const LR_LOADFROMFILE = &H10
Public Const LR_CREATEDIBSECTION = &H2000
Declare Function GetObject Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, _
ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Sub cmdCountColors256_Click()
Dim dibsect As DIBSECTION
Dim icount As Integer
Dim jcount As Integer
Dim colorcount As Integer
Dim startaddr As Long
Dim imagesize As Long
Dim imagewid As Long
Dim imagehgt As Long
Dim handl As Long
Dim bytesperscanline As Long
Dim lret As Long
Dim datarr() As Byte
Dim filename As String
Dim IndexArray(0 To 255) As Boolean
'Obviously, your filename here.
filename = "d:\testbitmaps\lion190x163_8.bmp"
handl = LoadImage(0, filename, IMAGE_BITMAP, _
0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
lret = GetObject(handl, Len(dibsect), dibsect)
With dibsect.dsBm
startaddr = .bmBits
imagewid = .bmWidth
imagehgt = .bmHeight
End With
With dibsect.dsBmih
imagesize = .biSizeImage
bytesperscanline = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)
End With
ReDim datarr(1 To bytesperscanline, 1 To imagehgt)
Call CopyMemory(datarr(1, 1), ByVal startaddr, imagesize)
For jcount = 1 To imagehgt
For icount = 1 To imagewid
IndexArray(datarr(icount, jcount)) = True
Next
Next
'Count the unique colors
colorcount = 0
For icount = 0 To 255
If IndexArray(icount) Then colorcount = colorcount + 1
Next
Print colorcount
End Sub
--
Richard Mason
Stephen Smith
from Richard Mason <ric...@whitney.demon.co.uk> contains these words:
> Private Sub cmdCountColors256_Click()
Good code Richard, I have learnt something from this. I suppose I had
better read up on DIBs and things :)
Steve.