VB 5/6-Tipp 0790: Zahl der Farben einer Bitmap

von Klaus Langbein

Beschreibung

Gelegentlich kommt es vor, dass man die Anzahl der Farben in einer Bitmap, bzw. einem Bild bestimmen muß. Hier wird, gezeigt, wie man dies effizient und schnell tun kann. Es werden zwei einfache Methoden vorgestellt, die auf unterschiedlichen Systemen unterschiedlich schnell sind und unterschiedlich viel Speicherplatz benötigen.

Anhand einer speziellen Funktion können Testbitmaps mit einer vorgegebenen Anzahl von Farben generiert werden, um die Algorithmen zu testen.
Schwierigkeitsgrad:
Schwierigkeitsgrad 2
Verwendete API-Aufrufe:
GetDIBits (GetDIBits256), GetObjectA (GetObject), SetDIBits (SetDIBits256)
Download:
Download des Beispielprojektes [253,88 KB]
'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'---------- Anfang Projektdatei prjColorCount.vbp  ----------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP6) (COMDLG32.OCX)' wird benötigt.

'--- Anfang Formular "frmColorCount" alias frmColorCount.frm  ---
' Steuerelement: Standarddialog-Steuerelement "CD1"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Dateiauswahlliste "File1"
' Steuerelement: Linien-Steuerelement "Line2"
' Steuerelement: Linien-Steuerelement "Line1"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label1"
' Anzahl der Farben einer Bitmap auslesen

' Autor/Copyright: K. Langbein, ActiveVB.de, März 2008

' Gelegentlich kommt es vor, dass man die Anzahl der Farben
' in einer Bitmap, bzw. einem Bild bestimmen muß. Hier wird,
' gezeigt, wie man dies effizient und schnell tun kann. Es werden
' zwei einfache Methoden vorgestellt, die auf unterschiedlichen
' Systemen unterschiedlich schnell sind und unterschiedlich viel
' Speicherplatz benötigen.
'
' Anhand einer speziellen Funktion können Testbitmaps mit einer
' vorgegebenen Anzahl von Farben generiert werden, um die Algorithmen
' zu testen.

Option Explicit

Dim t As Single

Private Const DIB_RGB_COLORS = 0

Private Declare Function GetObject Lib "gdi32" Alias _
        "GetObjectA" (ByVal hObject As Long, ByVal nCount As _
        Long, lpObject As Any) As Long

' Deklaration für Übergabe vo BITMAPINFO256, welche Platz für eine
' 256 Byte lange Farbpalette enthält.
Private Declare Function GetDIBits256 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 BITMAPINFO256, ByVal wUsage As Long) _
        As Long

         
Private Declare Function SetDIBits256 Lib "gdi32" Alias "SetDIBits" ( _
         ByVal hDc As Long, ByVal hBitmap As Long, _
         ByVal nStartScan As Long, ByVal nNumScans As Long, _
         lpBits As Any, lpBI As BITMAPINFO256, ByVal wUsage As Long) _
         As Long

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 BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

' Diese Sturktur enthält genügend Platz um auch eine
' Farbpalette aufzunehmen. Man kann sie für jede Art von
' Bitmap, also auch für Bitmaps ohne Palette einsetzen.
Private Type BITMAPINFO256
  bmiHeader As BITMAPINFOHEADER
  bmiColors(255) As Long
End Type

Public Function ColorCount1(ByVal ReferenceDC As Long, _
                            ByVal Handle As Long) As Long

    Static Table() As Byte
    Dim HiBits As Long
    Dim LoBits As Long
    Dim Pixels() As Long
    Dim Col As Long
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim cnt As Long
    Dim k As Long
    Dim Pow2(31) As Long
    Static IsInitiated As Boolean
    
    k = 2 ^ 24
    If IsInitiated = 0 Then
        ReDim Table(k) ' dann kostet die Dimensionierung Zeit
        IsInitiated = True
    Else
        ReDim Table(k) ' hier macht man zwar dasselbe, aber es
    End If             ' kostet keine Zeit. Man könnte auch
                       ' RtlZeromemory verwendeum um das Array zu
                       ' lerren. VB macht das jedoch auch mit Redim.

    n = GetBitmapData32(ReferenceDC, Handle, Pixels())
   
    If n <= 0 Then
        MsgBox "Cannot read data!"
        Exit Function
    End If
    
    t = Timer
    cnt = 0

    For i = 0 To UBound(Pixels)
    
       ' Wir schneiden das höchstwertige Byte ab, damit es
       ' keinen Index > 2^24 geben kann.
    
        Col = Pixels(i) And &HFFFFFF
        If Table(Col) = 0 Then
            cnt = cnt + 1
            Table(Col) = 1
            'Debug.Print Hex$(Col)
        End If
        
    Next i
    
    ColorCount1 = cnt

End Function

Public Function ColorCount2(ByVal ReferenceDC As Long, _
                            ByVal Handle As Long) As Long

    Dim Table() As Long
    Dim HiBits As Long
    Dim LoBits As Long
    Dim Pixels() As Long
    Dim Col As Long
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim cnt As Long
    Dim k As Long
    Dim Pow2(31) As Long
    
    k = 2 ^ 19 '524288
    ReDim Table(k)
    
    For i = 0 To 30
        Pow2(i) = 2 ^ i
    Next i
    Pow2(31) = &H80000000 ' Höchstwertigstes Bit gesetzt
    

    n = GetBitmapData32(ReferenceDC, Handle, Pixels())
   
    If n <= 0 Then
        MsgBox "Cannot read data!"
        Exit Function
    End If
    
    t = Timer
    cnt = 0
    
    For i = 0 To UBound(Pixels)
    
        ' Wir schneiden das höchstwertige Byte ab, damit es
        ' keinen Index > 2^24 geben kann.
        
        Col = Pixels(i) And &HFFFFFF
        HiBits = Col \ 32   ' Die höherwertigen Bits ergeben den Index
        LoBits = Col And 31 ' Die unteren 4 Bit werden in der Tabelle
                            ' in Form von Zweierpotenzen eingetragen
                            
        If (Table(HiBits) And Pow2(LoBits)) = 0 Then
            cnt = cnt + 1
            Table(HiBits) = Table(HiBits) Or Pow2(LoBits)
        End If
        
    Next i
    
    ColorCount2 = cnt

End Function

Function GetBitmapData32(ByVal hDc As Long, _
                         ByVal Handle As Long, _
                         Data() As Long) As Long
    
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim bInfo As BITMAPINFO256
    Dim nx As Long
    Dim ret As Long
    
    ret = GetObject(Handle, Len(bmp), bmp)
    If ret = 0 Then           ' Falls ein Fehler auftrat wird ret 0,
        GetBitmapData32 = -1  ' sonst ist es die Länge der übegebenen
        Exit Function         ' Struktur
    End If
     
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = 32
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von Data, dient zur Kontrolle. Wenn
    ' die Konversion funktioniert, wird unter W9x die Zahl der
    ' Bildzeilen zurückgegeben. Unter NT/XP wir ret <>0
    ret = GetDIBits256(hDc, Handle, 0, bmp.bmHeight, _
                                      ByVal 0, bInfo, DIB_RGB_COLORS)
    
    If ret = 0 Then           ' Falls ein Fehler auftrat wird ret 0
        GetBitmapData32 = -2
        Exit Function
    End If
                       
    ' Jetzt können wir die Breite einer Zeile berechnen. Im Fall
    ' der Konversion zu 32 Bit Farbtiefe entspricht die Zahl der
    ' benötigten Longs in x-Richtung der Breite des Bildes.
    nx = (bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight) / 4
    ReDim Data(nx * bmp.bmHeight - 1)
    
    ' Jetzt wird tatsächlich gelesen. Die Bitmapdaten befinden sich
    ' anschließend in Data().
    ret = GetDIBits256(hDc, Handle, 0, bmp.bmHeight, _
                                     Data(0), bInfo, DIB_RGB_COLORS)
                                     
    If ret = 0 Then         ' Falls ein Fehler auftrat wird ny = 0,
        GetBitmapData32 = -3
        ReDim Data(0, 0)
        Exit Function
    End If
                                     
'   Hier könnte man bereits das unbenutzte 4. Byte Null setzen.
'   Es ist jedoch günstiger, dies in der Zählroutine zu tun.
'   Wir schneiden das höchstwertigste Byte ab, damit es
'   keinen Überlauf gibt:
'    For i = 0 To UBound(Data)
'        Data(i) = Data(i) And &HFFFFFF
'    Next
                        
                        
    GetBitmapData32 = UBound(Data)
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox "Fehler in GetBitmapData32:" & vbCrLf & vbCrLf _
                & Err & ": " & Error$
        'Resume
    End Select
    
End Function

Function SetBitmapData32(ByVal hDc As Long, _
                         ByVal Handle As Long, _
                         Data() As Long) As Long
    
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim bInfo As BITMAPINFO256
    Dim nx As Long
    Dim ret As Long

    ret = GetObject(Handle, Len(bmp), bmp)
    If ret = 0 Then           ' Falls ein Fehler auftrat wird ret 0,
        SetBitmapData32 = -1  ' sonst ist es die Länge der übegebenen
        Exit Function         ' Struktur
    End If
     
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = 32
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von Data, dient zur Kontrolle. Wenn
    ' die Konversion funktioniert, wird unter W9x die Zahl der
    ' Bildzeilen zurückgegeben. Unter NT/XP wir ret <>0
    ret = GetDIBits256(hDc, Handle, 0, bmp.bmHeight, _
                                      ByVal 0, bInfo, DIB_RGB_COLORS)
    
    If ret = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        SetBitmapData32 = -2 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If
                       
      
    ' Jetzt die Daten in die Bitmap übertragen und von 32 Bit in
    ' die eingestellte Farbtiefe umgerechnet.
    ret = SetDIBits256(hDc, Handle, 0, bmp.bmHeight, _
                                      Data(0), bInfo, DIB_RGB_COLORS)
                                     
    If ret = 0 Then         ' Falls ein Fehler auftrat wird ny = 0,
        SetBitmapData32 = -3
        Exit Function
    End If
                                     
                        
    SetBitmapData32 = UBound(Data)
    
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox "Fehler in SetBitmapData32:" & vbCrLf & vbCrLf _
                & Err & ": " & Error$
        'Resume
    End Select
    
End Function


Private Sub Command1_Click()

    Dim n As Long
    Dim Handle As Long
    Handle = Picture1.Picture
    If Handle = 0 Then
        Handle = Picture1.Image
    End If
    
    n = ColorCount1(Picture1.hDc, Handle)
    Label1.Caption = "Anzahl der Farben: " & n _
                      & "   Zeit: " & Format$(Timer - t, "0.0000")

End Sub

Private Sub Command2_Click()

    Dim n As Long
    Dim Handle As Long
    
    Handle = Picture1.Picture
    If Handle = 0 Then
        Handle = Picture1.Image
    End If
    n = ColorCount2(Picture1.hDc, Handle)
    Label1.Caption = "Anzahl der Farben: " & n _
                      & "   Zeit: " & Format$(Timer - t, "0.0000")

    
End Sub


Private Sub Command3_Click()

    Dim Table() As Byte
    Dim nColors As Long
    Dim Col() As Long
    Dim i As Long
    Dim j As Long
    Dim Data() As Long
    Dim n As Long
    Dim nPix As Long
    Dim ok As Long
    Dim c As Long
    
    Picture1.ScaleMode = 3
    Picture1.AutoRedraw = True
    nPix = Picture1.ScaleHeight * Picture1.ScaleWidth
    
    nColors = 2 ^ 24 - 1
    ReDim Table(nColors)
    Table(0) = 1
    
    n = Val(Text1.Text)
    If n > nPix Then
        n = nPix
        Text1.Text = nPix
    End If
    ReDim Col(n)
    
    Randomize Timer
    For i = 1 To n
        Do
            ok = 0
            c = CLng(Rnd * nColors)
            If Table(c) = 0 Then
                Table(c) = 1
                j = j + 1
                Col(j) = c
                ok = 1
            Else
                'Beep
            End If
        Loop Until ok = 1
    Next i
    
    ReDim Data(nPix)
    j = 1
    For i = 0 To nPix
        Data(i) = Col(j)
        j = j + 1
        If j > UBound(Col) Then
            j = 1
        End If
    Next i
    
exi:

    Picture1.Cls
    Set Picture1.Picture = Nothing
    ok = SetBitmapData32(Picture1.hDc, Picture1.Image, Data())
    'Picture1.Picture = Picture1.Image ' kann man, muß man aber nicht
    Picture1.Refresh
    Label1.Caption = "Anzahl der Farben: ?         " _
                      & "   Zeit: ?"

End Sub

Private Sub Command4_Click()

    Dim Fn$
    Dim Pos As Long
    Dim i As Long
    
    CD1.ShowOpen
    Fn$ = CD1.FileName
    Pos = InStrRev(CD1.FileName, "\")
    If Pos > 0 Then
        Fn$ = Left$(Fn$, Pos - 1)
        File1.Path = Fn$
    End If
    Fn$ = CD1.FileTitle
    If Fn$ <> "" Then
        For i = 0 To File1.ListCount
            If Fn$ = File1.List(i) Then
                File1.ListIndex = i
                Exit For
            End If
        Next i
    End If
    
End Sub

Private Sub File1_Click()
    
    Dim Fn$
    Fn$ = File1.Path & "\" & File1.List(File1.ListIndex)
    Fn$ = Replace(Fn$, "\\", "\")
    Picture1.Picture = LoadPicture(Fn$)
    Label1.Caption = "Anzahl der Farben: ?        Zeit: ?"
    
    
End Sub

Private Sub Form_Load()

    Picture1.AutoSize = True
    Picture1.Picture = Picture1.Image
    File1.Pattern = "*.bmp;*.gif;*.jpeg;*.jpg"
    File1.Path = App.Path ' Hier ggf. Ordner mit Bildern eintragen
    
    If File1.ListCount > 0 Then
         File1.ListIndex = 0
    End If
    
    Label1.Caption = "Anzahl der Farben: ?        Zeit: ?"
    Command1.Caption = "Methode 1"
    Command2.Caption = "Methode 2"
    Command3.Caption = "Testbild"
    Command4.Caption = "Dialog"
    Text1.Text = "12345"
    
End Sub

Private Sub Form_Resize()

    If Me.WindowState <> 1 Then
        File1.Height = Me.Height - File1.Top - 400
    End If
    
End Sub
'--- Ende Formular "frmColorCount" alias frmColorCount.frm  ---
'----------- Ende Projektdatei prjColorCount.vbp  -----------
Tipp-Kompatibilität:
Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6
Ihre Meinung

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.