count colors in bitmap
in [Visual Basic]
|
From: Ulrich Korndoerfer on 7 Jul 2010 14:05 Hi, charles schrieb: > On 7 July, 14:35, "Larry Serflaten" <serfla...(a)gmail.com> wrote: > >> Did your examples access the image data from an array? >> Did you see this?http://www.vbaccelerator.com/codelib/gfx/dibsect.htm > > Yes, and I also saw the following vbaccelerator code which uses a > cDibSection Class to count the colors. > > http://www.vbaccelerator.com/home/vb/code/vbmedia/image_processing/Counting_Colours/Count_Colours_Sample.asp > > The problem is that it is quite slow, taking about two seconds for my > sample 1600 x 1200 pixel .bmp file. It runs a bit faster on my other > machine, about one and a half seconds, but it returns a completely > different answer for exactly the same .bmp file! Is there a faster and > more reliable way? A faster way might be to make a copy of the pixel colors into a 1dim array of longs. Then sort the array. After the array has been sorted, counting the number of unique colors is easy and requires one run over the sorted array. How fast this method is depends strongly on the sorting algorithm. Quick sort would be a good start. Even faster would be a counting sort. However the counting sort needs an additional helper array, which in the case of 24 bit color values has to have room for 24^2 entries. Such an array using Long as item type would need about 64 MBytes of memory. If you can afford that, go this route. Because for an eg. 2 MPixel picture there are at most 2 M different colors, and more likely the unique color count is much below, one could use kind of a sparse array for the helper array the counting sort needs. Either kind of hashing or a pseudo 2-dim array with entries created on demand would help. eg: Private Type TRedGreenEntry UniqueCount As Long Blue() As Long End Type 'First fill PixelColors with the pixel colors! 'Then call UniqueColorCount Private Function UniqueColorCount(ByRef PixelColors() As Long, _ ByVal PixelColorsCount As Long) _ As Long Dim Helper() As TRedGreenEntry Dim RGIdx As Long, BIdx As Long, i As Long ReDim Helper(0 To 2^16-1) 'Do the counting sort For i = 0 To PixelColorsCount - 1 RGidx = (PixelColors(i) And &HFFFF00) \ 256 BIdx = PixelColors(i) And &HFF With Helper(RGIdx) If .UniqueCount = 0 Then ReDim .Blue(0 To 255) .Blue(BIdx) = .Blue(BIdx) + 1& If .Blue(Idx) = 1& Then .UniqueCount = .UniqueCount + 1& End With Next i 'Now count the unique colors For i = 0 To 2^16-1 UniqueColorCount = UniqueColorCount + Helper(i).UniqueCount Next i End Function -- Ulrich Korndoerfer VB tips, helpers, solutions -> http://www.prosource.de/Downloads/ MS Newsgruppen Alternativen -> http://www.prosource.de/ms-ng-umzug.html
From: Mike Williams on 7 Jul 2010 15:15 "charles" <cbabbage59(a)yahoo.com> wrote in message news:47917783-6326-457a-9dc2-974fd5edd24d(a)y4g2000yqy.googlegroups.com... > In both cases it took about two seconds on one machine > and about one and a half seconds on the other to count > the colors. Do you have a faster way of doing it? Here's an example that counts the colours very quickly. For best results you should run it as a native code compiled exe, preferably using the Remove Integer Overflow Checks compiler optimization. On my own machine it counts the number of colours in a 1600 x 1200 pixel .bmp file in just over 30 milliseconds. This includes the time to load the file from disk, so it should be a bit quicker if your bitmap is already in memory. Paste the example into a VB Form containing a Command button and change the hard coded picture path to a standard full colour .bmp file that exists on your own machine. The example code as it stands deals only with standard .bmp image files (because it uses the LoadImage function to load them into a DIBSection) but you can use exactly the same counting technique on other kinds of images as long as you add the required code to load them into a DIBSection. Mike Option Explicit Private 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 Private Declare Function GetObject Lib "gdi32" _ Alias "GetObjectA" (ByVal hObject As Long, _ ByVal nCount As Long, lpObject As Any) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function VarPtrArray Lib "msvbvm60.dll" _ Alias "VarPtr" (Ptr() As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, _ ByVal ByteLen As Long) Private Const IMAGE_BITMAP = 0 Private Const LR_LOADFROMFILE = &H10 Private Const LR_CREATEDIBSECTION As Long = &H2000 Private Const LR_VGACOLOR As Long = &H80 Private Type SAFEARRAY1D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long cElements As Long lLbound As Long End Type Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private SourceWidth As Long, SourceHeight As Long Private clrs(0 To 2 ^ 21 - 1) As Byte Private TwoToThePowerOf(0 To 7) As Byte Private Declare Function timeGetTime _ Lib "winmm.dll" () As Long Private Declare Function timeBeginPeriod _ Lib "winmm.dll" (ByVal uPeriod As Long) As Long Private Declare Function timeEndPeriod _ Lib "winmm.dll" (ByVal uPeriod As Long) As Long Private Sub Form_Load() timeBeginPeriod 1 ' set timer resolution Dim n As Long For n = 0 To 7 TwoToThePowerOf(n) = 2 ^ n Next n End Sub Private Function CountColours(bmpFile As String) As Long ' Note: This task can be done using just a very small ' fraction of the declarations and the code used here, ' but it is actually faster (at least in VB6) to do it ' this much more code heavy way. ' This original testbed code specifically for use on ' full colour .bmp files and should be run as a native ' code compiled exe). Dim n As Long Dim j As Long, p As Long, used As Long Dim allclrsByte As Long, bitmask As Byte Dim myDIB As Long, bmpInf As BITMAP Dim sa1 As SAFEARRAY1D, sa2 As SAFEARRAY1D Dim sa3 As SAFEARRAY1D, sa4 As SAFEARRAY1D Dim sa5 As SAFEARRAY1D, bytePos As Long Dim SourceArray1() As Long, SourceArray2() As Long Dim SourceArray3() As Long, SourceArray4() As Long Dim sourcearray5() As Byte, done As Boolean Dim z As Byte, scanline As Long, LastLine As Boolean Dim bmpLongs As Long, oddPixels As Long, scanLongs As Long Dim twelves As Long ' number of blocks of 4 pixels (12 bytes) Dim fours As Long, offset As Long ' Note: We can save about 20 milliseconds (on a 4800x3600 bmp) ' or about a millisecond or so on a 1024x768 bmp) by loading ' the data into a VB Byte array rather than using LoadImage. ' (Might do that later). myDIB = LoadImage(0&, bmpFile, _ IMAGE_BITMAP, 0, 0, _ LR_LOADFROMFILE Or LR_CREATEDIBSECTION) GetObject myDIB, Len(bmpInf), bmpInf If myDIB = 0 Or bmpInf.bmBitsPixel <> 24 Then MsgBox "Not a valid full colour 24 bit .bmp file" Exit Function End If Erase clrs() ' clear the array that tracks each colour used GetObject myDIB, Len(bmpInf), bmpInf SourceWidth = bmpInf.bmWidth SourceHeight = bmpInf.bmHeight bmpLongs = (bmpInf.bmWidthBytes \ 4) * SourceHeight ' get data for a single scanline (first just 4 pixel blocks) twelves = ((SourceWidth * 3) \ 12) ' blocks of 12 bytes fours = twelves * 3 ' blocks of 4 bytes scanLongs = bmpInf.bmWidthBytes \ 4 oddPixels = SourceWidth - twelves * 4 ' Note: Instead of using a simple array of Longs on bitmap ' data returned by GetDIBits or a Byte array on the bitmap ' data directly using three Byte reads per pixel, this ' method points four separate arrays of Longs directly at ' slightly different positions in the same single block of ' bitmap data so that we can get at each pixel (3 bytes) ' with a single read. It's a bit unusual (a lot unusual) ' in that it reads Longs from the data at positions that ' do not start on a word boundary (the 3, 6, 9 stuff below) ' but it works very well and despite all the extra required ' code it is quite fast. This method uses a lot of code to ' do what would otherwise be a simple task, and so it is ' designed to run as a native code compiled exe (as is ' standard anyway with VB6) and such code will run very ' slowly in the VB6 IDE. On Error GoTo finish With sa1 .cDims = 1 ' one dimension .cbElements = 4 ' four bytes per element (array of Longs) .lLbound = 0 ' lBound .cElements = bmpLongs ' number of elements .pvData = bmpInf.bmBits ' point array1 (Longs) at DIB data byte zero End With ' the following arrangement of SAFEARRAY structures complicates ' matters but it enables us to deal with most of the RGB pixel ' data of each horizontal scanline in groups of twelve bytes ' (4 pixels) addressing each set of pixel data as a Long, which ' speeds up the code (the remaining odd pixels of each scanline, ' those not in a group of 12 bytes, are dealt with separately) LSet sa2 = sa1: sa2.pvData = sa1.pvData + 3 ' point array2 at byte 3 LSet sa3 = sa1: sa3.pvData = sa1.pvData + 6 ' point array3 at byte 6 LSet sa4 = sa1: sa4.pvData = sa1.pvData + 9 ' point array4 at byte 9 CopyMemory ByVal VarPtrArray(SourceArray1), VarPtr(sa1), 4 ' set up CopyMemory ByVal VarPtrArray(SourceArray2), VarPtr(sa2), 4 ' arrays CopyMemory ByVal VarPtrArray(SourceArray3), VarPtr(sa3), 4 ' as above CopyMemory ByVal VarPtrArray(SourceArray4), VarPtr(sa4), 4 LSet sa5 = sa1: sa5.cbElements = 1: sa5.cElements = bmpLongs * 4 CopyMemory ByVal VarPtrArray(sourcearray5), VarPtr(sa5), 4 ' j = red : j+1 = green : j+2 = blue For scanline = 0 To SourceHeight - 1 If scanline = (SourceHeight - 1) Then LastLine = True End If ' The following block contains an identical code block ' repeated numerous times simply because for this ' type of code a call to a function would waste a lot ' of time. Also, it adds extra logic to a specific ' task that would otherwise be a simple one liner ' because it uses bits rather than bytes or booleans ' to store each used colour. This additional logic ' slows the code down, but the slowdown is more than ' offset by the speed gained from having a much ' smaller block of flag data to access so that the ' data is usually read more quickly For j = 0 To fours - 3 Step 3 p = SourceArray1(j + offset) And &HFFFFFF allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If p = SourceArray2(j + offset) And &HFFFFFF allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If p = SourceArray3(j + offset) And &HFFFFFF allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If ' Check if on last Long of last scanline because if we ' address that location as a Long using the method we ' are using to address the three bytes of data the ' last byte of the Long will be one byte outside the ' area containing the DIB, which would cause serious ' problems (we won't need to bother with this if we ' later change to loading the bmp file straight into ' a VB array instead of using the LoadImage GDI ' function because we can then load it into a slightly ' larger data area). If LastLine = True And j = (fours - 3) Then bytePos = (j + offset) * 4 + 9 p = &H10000 * sourcearray5(bytePos + 2) _ + &H100& * sourcearray5(bytePos + 1) _ + sourcearray5(bytePos) allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If Else p = SourceArray4(j + offset) And &HFFFFFF allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If End If ' Next j If oddPixels > 0 Then ' here we need to do the odd pixels (not in groups ' of 12) at end of each scanline ' the number of of pixels is in the variable oddPixels bytePos = (j + offset + 3) * 4 For n = 0 To oddPixels - 1 p = &H10000 * sourcearray5(bytePos + 2) _ + &H100& * sourcearray5(bytePos + 1) _ + sourcearray5(bytePos) allclrsByte = p \ 8 bitmask = TwoToThePowerOf(7 - p Mod 8) z = clrs(allclrsByte) If (z And bitmask) = 0 Then used = used + 1 clrs(allclrsByte) = z Or bitmask End If bytePos = bytePos + 3 Next n End If Next j offset = offset + scanLongs ' offset next scanline Next scanline CountColours = used: done = True finish: ' release arrays CopyMemory ByVal VarPtrArray(SourceArray1), 0&, 4 CopyMemory ByVal VarPtrArray(SourceArray2), 0&, 4 CopyMemory ByVal VarPtrArray(SourceArray3), 0&, 4 CopyMemory ByVal VarPtrArray(SourceArray4), 0&, 4 CopyMemory ByVal VarPtrArray(sourcearray5), 0&, 4 DeleteObject myDIB If Not done Then CountColours = 0 End Function Private Sub Command1_Click() Dim tStart As Long, tFinish As Long Dim s1 As String, UniqueColours As Long tStart = timeGetTime UniqueColours = CountColours("c:\temp\jessica1.bmp") tFinish = timeGetTime If UniqueColours > 0 Then s1 = Format(SourceWidth) & " x " & Format(SourceHeight) _ & " pixel bmp file containing " & Format(UniqueColours) _ & " unique colours (" & Format(tFinish - tStart, "0.0") _ & " milliseconds)" MsgBox s1 Else MsgBox "Error dealing with bmp file" End If End Sub
From: Karl E. Peterson on 7 Jul 2010 17:08 After serious thinking Nobody wrote : > Here is some code from one of my projects that calculates how many ones are > there in a byte. For example, there are 3 ones in 00001110. This never > change, so this can be put in a 256 element array and used to quickly count > the number of ones in a byte. Here is the code: <snip> > For B = 0 To 255 > c = 0 > For i = 0 To 7 > If ((2 ^ i) And B) <> 0 Then > c = c + 1 > End If > Next > NumberOfOnes(B) = c > Next In a case like that (or, more importantly, like the one being discussed), I'd definitely urge precalculating the powers of two, rather than repeatedly incurring the same exponentiations. Could be a module level array, or a simple function (safer, but less efficient): Private Function TwoToThe(ByVal Power As Long) As Long Static BeenHere As Boolean Static Results(0 To 31) As Long Dim i As Long ' Build lookup table, first time through. ' Results hold powers of two from 0-31. If Not BeenHere Then For i = 0 To 30 Results(i) = 2 ^ i Next i Results(31) = &H80000000 BeenHere = True End If ' Return requested result If Power >= 0 And Power <= 31 Then TwoToThe = Results(Power) End If End Function -- ..NET: It's About Trust! http://vfred.mvps.org
From: charles on 8 Jul 2010 16:31 On 7 July, 20:15, "Mike Williams" <M...(a)WhiskeyAndCoke.com> wrote: > Here's an example that counts the colours very quickly. Thanks Mike. Just what I needed. Very, very fast, and very accurate. And it works correctly on both my machines. Thanks also to Dee Earley, Nobody, Karl Peterson and Ulrich Korndoerfer for your help. Charles
From: Ulrich Korndoerfer on 8 Jul 2010 22:47
Hi, charles schrieb: > On 7 July, 20:15, "Mike Williams" <M...(a)WhiskeyAndCoke.com> wrote: > >> Here's an example that counts the colours very quickly. > > Thanks Mike. Just what I needed. Very, very fast, and very accurate. > And it works correctly on both my machines. Thanks also to Dee Earley, > Nobody, Karl Peterson and Ulrich Korndoerfer for your help. Never mind. My example given was "top off the head", in the meanwhile I got something better ;-) When interested, see below. '******************************************************************************* '* Private API method declarations, types, consts '******************************************************************************* Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _ (ByVal hInst As Long, _ ByVal lpszName As String, _ ByVal uType As Long, _ ByVal cxDesired As Long, _ ByVal cyDesired As Long, _ ByVal fuLoad As Long) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" _ (ByVal hObject As Long, _ ByVal nCount As Long, _ ByRef lpObject As Any) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" _ (ByRef Arr() As Any) As Long Private Declare Sub PokeLong Lib "msvbvm60" Alias "PutMem4" _ (ByVal Addr As Long, _ ByVal Value As Long) Private Const IMAGE_BITMAP = 0 Private Const LR_LOADFROMFILE = &H10 Private Const LR_CREATEDIBSECTION As Long = &H2000 Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long 'Scan line width bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Type SAFEARRAY1D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long cElements As Long lLbound As Long End Type '******************************************************************************* '* Public methods '******************************************************************************* 'Processes 24 bpp bitmaps only. Convenience method as wrapper for the calls 'needed for loading the bitmap and counting the colors 'On failure returns -1, otherwise the count of unique colors of the bitmap Public Function gUniqueColorCountFromFile(ByVal File As String) As Long Dim DIB As Long DIB = gLoadBitmapFromFile(File) If DIB <> 0 Then gUniqueColorCountFromFile = gUniqueColorCountFromDIB(DIB) gFreeDIB DIB Else gUniqueColorCountFromFile = -1 End If End Function 'Loads 24 bpp bitmaps only. Scanlines may be padded or not. 'On failure returns 0, otherwise a valid DIB, which has to be freed later! Public Function gLoadBitmapFromFile(ByVal File As String) As Long Dim BmpBitsPerPixel As Long, DIB As Long DIB = LoadImage(0&, File, IMAGE_BITMAP, 0, 0, _ LR_LOADFROMFILE Or LR_CREATEDIBSECTION) If DIB = 0 Then Exit Function GetBitmapInfo DIB, BmpBitsPerPixel If BmpBitsPerPixel <> 24 Then gFreeDIB DIB: Exit Function gLoadBitmapFromFile = DIB End Function Public Sub gFreeDIB(ByRef DIB As Long) If DIB <> 0 Then DeleteObject DIB: DIB = 0 End Sub 'Processes 24 bpp bitmaps only, DIB from function gLoadBitmapFromFile 'During processing creates and uses a 2097152 bytes big array! 'Is runnable in the IDE or compiled to pcode, but for better performance 'compile to native code. Max performance is achieved when array bounds 'and integer overflow checks are disabled. 'On failure returns -1, otherwise the count of unique colors of the bitmap Public Function gUniqueColorCountFromDIB(ByVal DIB As Long) As Long Dim BmpWidth As Long, BmpHeight As Long, BmpBitsPerPixel As Long Dim BmpScanLineSize As Long, BmpBitsAddress As Long Dim ScanLine() As Long, ScanLineSA As SAFEARRAY1D Dim Count As Long Dim ExcessPixels As Long, MaxIdx As Long Dim Flags() As Long, FlagIdx As Long Dim Bitmask As Long, Bitmasks() As Long Dim i As Long, RunIdx As Long, ScanLineIdx As Long On Error GoTo MethodError '* Setup all '524288 Longs, room for 16777216 = 2^24 bits ReDim Flags(0 To 2 ^ 19 - 1) As Long ReDim Bitmasks(0 To 31) Bitmasks(0) = 1 For i = 1 To 30 Bitmasks(i) = Bitmasks(i - 1) * 2& Next i Bitmasks(i) = &H80000000 GetBitmapInfo DIB, BmpBitsPerPixel, BmpWidth, BmpHeight, _ BmpScanLineSize, BmpBitsAddress If BmpBitsPerPixel <> 24 Then GoTo MethodError ScanLinePtrSet ScanLine, ScanLineSA, BmpWidth, BmpBitsAddress ExcessPixels = BmpWidth Mod 4 MaxIdx = (BmpWidth - 1) \ 4 '* Now count For ScanLineIdx = 0 To BmpHeight - 1 ScanLineSA.pvData = UAdd(BmpBitsAddress, ScanLineIdx * BmpScanLineSize) For RunIdx = 1 To 4 i = MaxIdx If ExcessPixels <> 0 Then If RunIdx > ExcessPixels Then i = i - 1 End If For i = 0 To i * 3 Step 3 'Forwards 12 bytes per iteration FlagIdx = ScanLine(i) And &HFFFFFF Bitmask = Bitmasks(FlagIdx And &H1F&) FlagIdx = FlagIdx \ 32& If (Flags(FlagIdx) And Bitmask) = 0& Then Count = Count + 1& Flags(FlagIdx) = Flags(FlagIdx) Or Bitmask End If Next i ScanLineSA.pvData = UAdd(ScanLineSA.pvData, 3) Next RunIdx Next ScanLineIdx '* Finished gUniqueColorCountFromDIB = Count GoTo MethodExit MethodError: gUniqueColorCountFromDIB = -1 MethodExit: ScanLinePtrFree ScanLine End Function '******************************************************************************* '* Private helpers '******************************************************************************* Private Sub GetBitmapInfo(ByVal DIB As Long, _ Optional ByRef BmpBitsPerPixel As Long, _ Optional ByRef BmpWidth As Long, _ Optional ByRef BmpHeight As Long, _ Optional ByRef BmpScanLineSize As Long, _ Optional ByRef BmpBitsAddress As Long) Dim BmpInfo As BITMAP GetObject DIB, Len(BmpInfo), BmpInfo With BmpInfo BmpBitsPerPixel = .bmBitsPixel BmpWidth = .bmWidth BmpHeight = .bmHeight BmpScanLineSize = .bmWidthBytes BmpBitsAddress = .bmBits End With End Sub Private Sub ScanLinePtrSet(ByRef ScanLine() As Long, _ ByRef ScanLineSA As SAFEARRAY1D, _ ByRef BmpWidth As Long, _ ByRef BmpBitsAddress As Long) With ScanLineSA .cDims = 1 .cbElements = 4 .cElements = BmpWidth .pvData = BmpBitsAddress End With PokeLong VarPtrArray(ScanLine), VarPtr(ScanLineSA) End Sub Private Sub ScanLinePtrFree(ByRef ScanLine() As Long) PokeLong VarPtrArray(ScanLine), 0 End Sub 'Unsigned addition 'Allowed ranges: 'Op1: 0 to &HFFFFFFFF 'Op2: 0 to &HFFFFFFFF Private Function UAdd(ByVal Op1 As Long, ByVal Op2 As Long) As Long UAdd = (((Op1 Xor &H80000000) + (Op2 And &H7FFFFFFF)) _ Xor &H80000000) Or (Op2 And &H80000000) End Function -- Ulrich Korndoerfer VB tips, helpers, solutions -> http://www.prosource.de/Downloads/ MS Newsgruppen Alternativen -> http://www.prosource.de/ms-ng-umzug.html |