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: | Verwendete API-Aufrufe: GetDIBits (GetDIBits256), GetObjectA (GetObject), SetDIBits (SetDIBits256) | Download: |
'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.