count colors in bitmap
in [Visual Basic]
|
From: charles on 9 Jul 2010 07:17 On 9 July, 03:47, Ulrich Korndoerfer <ulrich_wants_nos...(a)prosource.de> wrote: > 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 > '******************************************************************************* Thanks Ulrich. That's almost as fast as Mike's code so it should be quite useful. There is one little problem with your code though in that it crashes on some bitmaps and I get the "Send Error Report to Microsoft" message box. Any idea what might be causing that? Charles
From: ralph on 9 Jul 2010 09:45 On Fri, 9 Jul 2010 04:17:21 -0700 (PDT), charles <cbabbage59(a)yahoo.com> wrote: >On 9 July, 03:47, Ulrich Korndoerfer ><ulrich_wants_nos...(a)prosource.de> wrote: > >> 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 >> '**************************************************************************�***** > >Thanks Ulrich. That's almost as fast as Mike's code so it should be >quite useful. There is one little problem with your code though in >that it crashes on some bitmaps and I get the "Send Error Report to >Microsoft" message box. Any idea what might be causing that? > Can't help with the specific error, but while developing it is useful to turn off the "Send Error Report to Microsoft" option off, and to install a JIT debugger to catch the error for your review. (How depends on your O/S and what debugger you choose. Retrieve details in Help.) I prefer WinDbg. http://www.microsoft.com/whdc/DevTools/Debugging/default.mspx This will at least provide some clues as to where and what. -ralph
From: Mike Williams on 11 Jul 2010 03:38 "charles" <cbabbage59(a)yahoo.com> wrote in message news:d49aefcb-5406-452f-b17b-3814715774af(a)a30g2000yqn.googlegroups.com... > Thanks Mike. Just what I needed. You're welcome. By the way, although the code I previously posted is very fast it does slow down a little when dealing with images that are not an exact multiple of 4 pixels wide. Here is a slightly modified version in which there is no slowdown when dealing with such images. The code is quite long, because it is built for speed rather than neatness, and so I have removed all the comment lines in order to comply with the Posting Restrictions [Maximum Content] Order (2010) recently issued by Larry Serflaten, the newly self appointed group moderator. 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 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 Dim n As Long, temp As Long, GetLastPixel As Long Dim j As Long, p As Long, used As Long, foursMinusThree 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 Dim fours As Long, offset As Long 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() GetObject myDIB, Len(bmpInf), bmpInf SourceWidth = bmpInf.bmWidth SourceHeight = bmpInf.bmHeight bmpLongs = (bmpInf.bmWidthBytes \ 4) * SourceHeight twelves = ((SourceWidth * 3) \ 12) fours = twelves * 3 scanLongs = bmpInf.bmWidthBytes \ 4 oddPixels = SourceWidth - twelves * 4 On Error GoTo finish With sa1 .cDims = 1 .cbElements = 4 .lLbound = 0 .cElements = bmpLongs .pvData = bmpInf.bmBits End With LSet sa2 = sa1: sa2.pvData = sa1.pvData + 3 LSet sa3 = sa1: sa3.pvData = sa1.pvData + 6 LSet sa4 = sa1: sa4.pvData = sa1.pvData + 9 CopyMemory ByVal VarPtrArray(SourceArray1), VarPtr(sa1), 4 CopyMemory ByVal VarPtrArray(SourceArray2), VarPtr(sa2), 4 CopyMemory ByVal VarPtrArray(SourceArray3), VarPtr(sa3), 4 CopyMemory ByVal VarPtrArray(SourceArray4), VarPtr(sa4), 4 LSet sa5 = sa1: sa5.cbElements = 1: sa5.cElements = bmpLongs * 4 CopyMemory ByVal VarPtrArray(sourcearray5), VarPtr(sa5), 4 foursMinusThree = fours - 3 For scanline = 0 To SourceHeight - 1 If scanline = (SourceHeight - 1) Then LastLine = True GetLastPixel = 0 End If For j = 0 To foursMinusThree 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 If (LastLine = False) Or (j <> foursMinusThree) Then 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 Else GetLastPixel = ((j + offset) * 4) + 9 End If Next j If GetLastPixel <> 0 Then p = &H10000 * sourcearray5(GetLastPixel + 2) _ + &H100& * sourcearray5(GetLastPixel + 1) _ + sourcearray5(GetLastPixel) 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 GetLastPixel = 0 End If If oddPixels <> 0 Then temp = oddPixels If (LastLine = False) Or (temp <> 1) Then 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 Else GetLastPixel = (j + offset) * 4 Exit For End If temp = temp - 1 If temp <> 0 Then If (LastLine = False) Or (temp <> 1) Then 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 Else GetLastPixel = ((j + offset) * 4) + 3 Exit For End If End If temp = temp - 1 If temp <> 0 Then If (LastLine = False) Or (temp <> 1) Then 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 Else GetLastPixel = ((j + offset) * 4) + 6 Exit For End If End If End If offset = offset + scanLongs Next scanline If GetLastPixel <> 0 Then p = &H10000 * sourcearray5(GetLastPixel + 2) _ + &H100& * sourcearray5(GetLastPixel + 1) _ + sourcearray5(GetLastPixel) 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 CountColours = used: done = True finish: 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: Mike Williams on 11 Jul 2010 18:00 "charles" <cbabbage59(a)yahoo.com> wrote in message news:4bf04fa4-b6ff-4708-b5e2-75dba5315ef6(a)c10g2000yqi.googlegroups.com... Thanks Ulrich. That's almost as fast as Mike's code so it should be quite useful. There is one little problem with your code though in that it crashes on some bitmaps and I get the "Send Error Report to Microsoft" message box. Any idea what might be causing that? I waited a reasonable time for Ulrich to respond to your question about his code crashing on some bitmaps, but since he has not yet done so I'm sure he won't mind if I respond to it myself. In order not to upset Larry Serflaten, who abhors detailed responses, I'll explain it only in as much detail as is necessary for you to see what the problem actually is. The reason Ulrich's code bombs out and crashes on some images and not on others is that on some specific sized bitmaps his code is addressing a data byte that is outside the block of data that the system has allocated to the DIB. Generally the system allocates memory for such things in multiples of 4KB, so it rounds up the actual required memory for the DIB to the nearest 4KB and then allocates that amount of memory. In some cases the actual DIB data (the three bytes per pixel data for the bitmap) does not actually fill the entire block that has been allocated, and so if your code inadvertently accesses a memory location that is slightly outside the actual DIB pixel data there is no problem. However, in cases where the pixel area of the DIB is such that it actually requires /exactly/ a multiple of 4KB then there will be a problem if your code inadvertently accesses a byte that is outside of the DIB data, even if it is just a single byte outside the actual DIB data, since that byte will also be outside of the block of memory that has been allocated by the system. In the case of Ulrich's code (and also in the case of my own code) the data for the DIB is actually accessed as a 4 byte Long for each pixel, with an appropriate mask being applied to the long (and in Ulrich's case some appropriate conversions) depending on the location of the three bytes of pixel data within that Long. This means that the three bytes for the very last pixel of the DIB will usually be in a Long that extends one byte outside the actual DIB data area. This does not matter when the memory block allocated to the DIB by the system is greater than the actual data size of the DIB (the "nearest 4KB thing") but it /does/ matter when the memory allocated by the system for the DIB is /exactly/ the same size as the required DIB data. In such a case the "extra byte being addressed" lies outside the allocated memory block, which is what causes the crash. In my own code I have taken steps to prevent such an illegal memory access, but in Ulrich's code he has not done so, hence the crash in Ulrich's code on some bitmaps. Full colour 24 bit Bitmaps that occupy an /exact/ multiple of 4KB of DIB data are in fact quite common (1024 x 768, 2048 x 1536, 3072 x 2304 and 3200 x 2400 and some others are all fairly common bitmap sizes that fall into this category) and Ulrich's code, as it stands, will crash on all of those bitmaps. Actually, looking back on what I have just written, there is more than I had intended to write and I do hope that I have not upset Larry Serflaten, the newly self appointed group moderator who believes that, in his own words, my know-it-all replies border on narcissism with a touch of superiority complex which he just finds a bit distasteful, time after time. If this response has upset Larry again then I do apologise for it, but I really do feel that it is more important for the OP to get his answer than it is for Larry's sensibilties to be protected :-) Mike
From: Larry Serflaten on 11 Jul 2010 21:44
"Mike Williams" <Mike(a)WhiskeyAndCoke.com> wrote > newly self appointed group moderator who believes that, in his own words, > my know-it-all replies border on narcissism with a touch of superiority > complex which he just finds a bit distasteful, time after time. nar�cis�sism - noun 1.inordinate fascination with oneself; excessive self-love; vanity. 2.Psychoanalysis. erotic gratification derived from admiration of one's own physical or mental attributes, being a normal condition at the infantile level of personality development. Are you not quite all grown up yet Mike? You can stop your childish games anytime now..... LFS |