Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0509: Veränderung von Bitmaps durch Manipulation der Farbpalette

VB 5/6-Tipp 0509: Veränderung von Bitmaps durch Manipulation der Farbpalette

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CreatePalette, DeleteObject, GetDIBits, GetDIBits (GetDIBits256), GetDIBits (GetDIBitsPAL), GetObjectA (GetObject), RealizePalette, SelectPalette, SetDIBits, SetDIBits (SetDIBits256), SetDIBits (SetDIBitsPAL)

Download: Download des Beispielprojektes [275,16 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 Project1.vbp -------------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
'
' Autor: K. Langbein Klaus@ActiveVB.de
'
' Beschreibung:
' VB kann Bitmaps immer nur im Format der aktuellen
' Monitoreinstellung abspeichern. Bei eingachen Grafiken ist es
' jedoch oft sinnvol ein Bild mit geringerer Farbauflösung oder
' sogar in schwarz/weiß abszuspeichern. Mit Hilfe des API-Befehls
' GetDiBits können geräteunabhängige Bitmaps (DIBs) aus dem Image
' oder Picture einer Picturebox erstellt werden. Das resultierende
' Datenfeld kann dann zusammen mit dem entsprechenden Header als
' DIB mit der gewünschten Farbtiefe abgespeichert werden.
'
' Chronologie und Referenzen
' Ein ähnliches Programm wird in den Beispielen zur
' Programmiersprache GFA-Basic (www.gfasoft.gfa.net) mitgeliefert.
' Dieser Sourcecode wurde mit Mühen und etlichen Abstürzen nach VB
' portiert und optimiert. Erst durch einen Hinweis in "VB Programmer's
' Guide to the Win32 API" von Dan Appleman wurde die Abfrage der
' resultierenden Dateigröße möglich: Der Wert 0 als Stellvertreter
' für die Übergabe des Datenfeldes muß mit Byval übergeben werden!
'
' Der Anstoß zur Erstellung dieses Tipps kam durch wiederholte
' Anfragen im ActiveVB-Forum zustande. Die letzte Anfrage kam von
' Siml <blue-siml@gmx.net>. Er hat sich daher bereit erklärt die
' Benutzeroberfläche etwas auszubauen und das Testbild und einen
' Teil der Kommentierung hinzuzufügen.

Option Explicit
Public Const DIB_RGB_COLORS = 0
Public Const DIB_PAL_COLORS = 1

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

' Dies ist die übliche Deklaration für GetDIBits. Sie wird hier
' in dieser Form nicht verwendet, da die Struktur BITMAPINFO
' in modifizierter Form übergeben werden muß.
Public Declare Function GetDIBits Lib "gdi32" (ByVal _
        aHDC As Long, ByVal hBitmap As Long, ByVal _
        nStartScan As Long, ByVal nNumScans As Long, lpBits _
        As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) _
        As Long

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

Public 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

Public 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

Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

' Die Farben einer Bitmap sind üblicherweise so wie im unten
' definierten Typ RGBQUAD angeordnet. D.h. Blau steht an erster,
' und Rot steht an dritter Stelle. In einer Variablen vom Typ
' Long steht der Rotwert im niederwertigsten Byte, was jedoch
' auf Grund der Vertauschung der Bytefolge bei Intelprozessoren
' im Speicher links steht. RGBQUAD wird hier nicht verwendet;
' stattdessen wird die Funktion SwapRedBlue eingesetzt, um die
' richtige Bytefolge für Farbpaletten zu erhalten .
Public Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type

' Dies ist die übliche Deklaration für BITMAPINFO -
' sie wird hier nicht verwendet.
Public Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As Long
End Type

' Dies ist die Stuktur die hier zum Einsatz kommt. Sie
' ist groß genug um eine Farbpalette mit einer Länge von 256
' Byte aufzunehmen. Übergibt man beim Aufruf von GetDiBits die
' oben deklarierte Datenstruktur, kommt es zum Absturz, da der
' Speicherbereich oberhalb von BITMAPINFO mit den Daten der
' Palette überschrieben wird.
Public Type BITMAPINFO256
  bmiHeader As BITMAPINFOHEADER
  bmiColors(255) As Long
End Type

Public Type BITMAPINFOPAL
  bmiHeader As BITMAPINFOHEADER
  bmiColors(255) As Integer
End Type

'**********************************************************************************
' P A L E T T E
'**********************************************************************************
Public Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Public Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type

Public LogPal As LOGPALETTE
Public hPal As Long

Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long

Public Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long
    
Public Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long


Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Function bin_32(ByVal v As Long) As String

    Dim hexx As String
    Dim i As Long
    Dim bb As Long
    Dim res As String
    Dim tst As String
    
    hexx = Hex$(v)
    hexx = String$(8 - Len(hexx), "0") + hexx
    res = ""
    For i = 1 To 7 Step 2
    
        tst = Mid$(hexx$, i, 2)
        If tst <> "00" Then
            bb = Val("&H" + tst)
            res = res + " " + bin_8(bb)
        Else
            res = res + " " + "00000000"
        End If
    
    Next i
    bin_32 = res

End Function
Function bin_8(ByVal v As Double) As String

' looks clumbsy but is faster than loop
' with calculation
    
    Dim k As Long
    Dim test As String
    
    test = String$(8, "0")
    
    If v And 1 Then
        Mid$(test, 8, 1) = "1"
    End If
    If v And 2 Then
        Mid$(test, 7, 1) = "1"
    End If
    If v And 4 Then
        Mid$(test, 6, 1) = "1"
    End If
    If v And 8 Then
        Mid$(test, 5, 1) = "1"
    End If
    If v And 16 Then
        Mid$(test, 4, 1) = "1"
    End If
    If v And 32 Then
        Mid$(test, 3, 1) = "1"
    End If
    If v And 64 Then
        Mid$(test, 2, 1) = "1"
    End If
    If v And 128 Then
        Mid$(test, 1, 1) = "1"
    End If
   
    bin_8 = test
    'MsgBox test
End Function


Function GetRGB(ByVal col As Long, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
    Dim green As Long, blue As Long
    
    r = col And 255
    green = col And 65280
    green = green / 256   '2 ^ 8
    blue = col And 16711680
    blue = blue / 65536 ' 2^16
    g = green
    b = blue
    
End Function

Function SaveBitmap_AllRes(hDC As Long, handle As Long, _
                           ByVal BitsPerPixel As Long, _
                           ByVal fname As String, _
                           Optional NewPal As Variant) As Long
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim i As Integer
    Dim bInfo As BITMAPINFO256
    Dim FileHeader As BITMAPFILEHEADER
    Dim bArray() As Byte
    Dim nLines As Long
    Dim WidthArray As Long
    Dim fno As Long
    Dim palette() As Long
    Dim newP As Long
    Dim nCol As Long
    
    Call GetObject(handle, Len(bmp), bmp)
    
    Select Case BitsPerPixel
    Case 1, 4, 8, 16, 24, 32
        ' kein Fehler. weiter gehts!
    Case Else
        MsgBox "Fehler!" & vbCrLf & "Dieses Bildformat wird nicht unterstützt!"
        SaveBitmap_AllRes = -1
        Exit Function
    End Select
   
    If IsMissing(NewPal) = 0 Then
        newP = UBound(NewPal)
    End If
     
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = BitsPerPixel
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von bArray, dient dazu die Größe
    ' des benötigten Feldes festzustellen. Die Palette wir hier auch
    ' schon übertragen.
    nLines = GetDIBits256(hDC, handle, 0, bmp.bmHeight, _
                       ByVal 0, bInfo, DIB_RGB_COLORS)
    
    If nLines = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        SaveBitmap_AllRes = -2 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If
                       
    ' Jetzt können wir die Breite einer Zeile berechnen. Diese ist
    ' nicht notwendigerweise wie erwartet, sondern enthält evtl.
    ' sogenannte Padbytes.
    WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
    ReDim bArray(1 To WidthArray, 1 To bInfo.bmiHeader.biHeight)
    
    ' Jetzt wird tatsächlich gelesen. Die Bitmapdaten befinden sich
    ' anschließend in bArray und könnten hier auch manipuliert werden.
    nLines = GetDIBits256(hDC, handle, 0, bmp.bmHeight, _
                        bArray(1, 1), bInfo, DIB_RGB_COLORS)
                        
    If nLines = 0 Then
        SaveBitmap_AllRes = -3 ' Tja, dann ist wohl was schiefgelaufen.
        Exit Function
    End If
    
    Select Case BitsPerPixel

    Case 1
        bInfo.bmiHeader.biClrUsed = 2
        bInfo.bmiHeader.biClrImportant = 2
        nCol = 1
    Case 4
        bInfo.bmiHeader.biClrUsed = 16
        bInfo.bmiHeader.biClrImportant = 16
        nCol = 15
    Case 8
        bInfo.bmiHeader.biClrUsed = 256
        bInfo.bmiHeader.biClrImportant = 256
        nCol = 255
    Case 16, 24, 32
        nCol = 0
    End Select
    
    ReDim palette(nCol)
    ' Hier wird umgespeichert, damit wir die Palette einfach mit Put
    ' ausgeben können. Gleichzeitig können wir eine an die Funktion
    ' übergebene Palette (NewPal) verwenden.
    If nCol > 0 Then
        If newP = nCol Then
            For i = 0 To nCol
                palette(i) = SwapRedBlue(NewPal(i)) ' Rot und Blau sind
                ' in normalen Longs vertauscht. Wir korrigieren das hier.
            Next i
        Else
            For i = 0 To nCol
                palette(i) = bInfo.bmiColors(i)
            Next i
        End If
    Else
        palette(0) = 0
    End If
    
    FileHeader.bfType = 19778 ' entspricht "BM"
    FileHeader.bfOffBits = Len(FileHeader) + Len(bInfo.bmiHeader)
    FileHeader.bfOffBits = FileHeader.bfOffBits + (UBound(palette) + 1) * 4
    FileHeader.bfSize = Len(FileHeader) + Len(bInfo.bmiHeader) + (UBound(palette) + 1) * 4
    
    fno = FreeFile
    Open fname For Binary As #fno
    ' und wieder Ausspucken...
    Put #fno, , FileHeader
    Put #fno, , bInfo.bmiHeader
    Put #fno, , palette()
    Put #fno, , bArray()
    Close #fno
    SaveBitmap_AllRes = FileLen(fname)
    
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox "Fehler!" & vbCrLf & Error$
        'Resume
    End Select
    
End Function

Function GetPalette_AllRes(hDC As Long, handle As Long, _
                           ByVal BitsPerPixel As Long, _
                           palette() As Long) As Long
                           
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim bInfo As BITMAPINFO256
    Dim FileHeader As BITMAPFILEHEADER
    Dim bArray() As Byte
    Dim nLines As Long
    Dim WidthArray As Long
    Dim fno As Long
    Dim newP As Long
    Dim nCol As Long
    Dim i As Long
    
    Call GetObject(handle, Len(bmp), bmp)
    
    Select Case BitsPerPixel
    Case 1, 4, 8, 16, 24, 32
        ' nothing ;-)
    Case Else
        MsgBox "Sorry, unsupported format!"
        GetPalette_AllRes = -1
        Exit Function
    End Select
        
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = BitsPerPixel
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von bArray, dient dazu die Größe
    ' des benötigten Feldes festzustellen. Die Palette wir hier auch
    ' schon übertragen.
    nLines = GetDIBits256(hDC, handle, 0, bmp.bmHeight, _
                       ByVal 0, bInfo, DIB_RGB_COLORS)
    
    If nLines = 0 Then
        GetPalette_AllRes = -2
        Exit Function
    End If
       
    Select Case BitsPerPixel

    Case 1
        nCol = 1
    Case 4
         nCol = 15
    Case 8
        nCol = 255
    Case 16, 24, 32
        nCol = 0
    End Select
    
    ReDim palette(nCol)
   
    If nCol > 0 Then
        For i = 0 To nCol
            palette(i) = SwapRedBlue(bInfo.bmiColors(i))  ' Rot und Blau sind
            ' in normalen Longs vertauscht. Wir korrigieren das hier.
        Next i
      Else
        palette(0) = 0
    End If
    GetPalette_AllRes = nCol
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox Error$
        'Resume
    End Select
    
End Function

Function ConvBitmap_AllRes(hDC As Long, _
                           handle1 As Long, _
                           handle2 As Long, _
                           ByVal BitsPerPixel As Long, _
                           Optional NewPal As Variant) As Long
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim bInfo As BITMAPINFO256
    Dim FileHeader As BITMAPFILEHEADER
    Dim bArray() As Byte
    Dim nLines As Long
    Dim WidthArray As Long
    Dim fno As Long
    Dim palette() As Long
    Dim newP As Long
    Dim nCol As Long
    Dim i As Long
    
    Call GetObject(handle1, Len(bmp), bmp)
    
    Select Case BitsPerPixel
    Case 1, 4, 8, 16, 24, 32
        ' nothing ;-)
    Case Else
        MsgBox "Sorry, unsupported format!"
        ConvBitmap_AllRes = -1
        Exit Function
    End Select
   
    If IsMissing(NewPal) = 0 Then
        newP = UBound(NewPal)
    End If
     
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = BitsPerPixel
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von bArray, dient dazu die Größe
    ' des benötigten Feldes festzustellen. Die Palette wir hier auch
    ' schon übertragen.
    nLines = GetDIBits256(hDC, handle1, 0, bmp.bmHeight, _
                       ByVal 0, bInfo, DIB_RGB_COLORS)
    
    If nLines = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        ConvBitmap_AllRes = -2 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If
                       
    ' Jetzt können wir die Breite einer Zeile berechnen. Diese ist
    ' nicht notwendigerweise wie erwartet, sondern enthält evtl.
    ' sogenannte Padbytes.
    WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
    ReDim bArray(1 To WidthArray, 1 To bInfo.bmiHeader.biHeight)
    
    ' Jetzt wird tatsächlich gelesen. Die Bitmapdaten befinden sich
    ' anschließend in bArray und könnten hier auch manipuliert werden.
    nLines = GetDIBits256(hDC, handle1, 0, bmp.bmHeight, _
                        bArray(1, 1), bInfo, DIB_RGB_COLORS)
                        
    If nLines = 0 Then
        ConvBitmap_AllRes = -3 ' Tja, dann ist wohl was schiefgelaufen.
        Exit Function
    End If
    
    Select Case BitsPerPixel

    Case 1
        bInfo.bmiHeader.biClrUsed = 2
        bInfo.bmiHeader.biClrImportant = 2
        nCol = 1
    Case 4
        bInfo.bmiHeader.biClrUsed = 16
        bInfo.bmiHeader.biClrImportant = 16
        nCol = 15
    Case 8
        bInfo.bmiHeader.biClrUsed = 256
        bInfo.bmiHeader.biClrImportant = 256
        nCol = 255
    Case 16, 24, 32
        nCol = 0
    End Select
    
    ReDim palette(nCol)
    ' Hier wird umgespeichert, damit wir die Palette einfach mit Put
    ' ausgeben können. Gleichzeitig können wir eine an die Funktion
    ' übergebene Palette (NewPal) verwenden.
    If nCol > 0 Then
        If newP = nCol Then
            For i = 0 To nCol
                palette(i) = SwapRedBlue(NewPal(i)) ' Rot und Blau sind
                ' in normalen Longs vertauscht. Wir korrigieren das hier.
            Next i
        Else
            For i = 0 To nCol
                palette(i) = bInfo.bmiColors(i)
            Next i
        End If
    Else
        palette(0) = 0
    End If
    
    ' Hier wird die konvertierte Bitmap an das handle des Ausgabecontrols
    ' übergeben.
    nLines = SetDIBits256(hDC, handle2, 0, bmp.bmHeight, _
                        bArray(1, 1), bInfo, DIB_RGB_COLORS)
                        
                        
    
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox Error$
        Resume
    End Select
    
End Function
Function ConvBimap_to_Pal(hDC As Long, _
                           handle1 As Long, _
                           handle2 As Long, _
                           ByVal nSteps As Long, _
                           ByVal col As Long, _
                           ByVal GreyIn As Boolean) As Long
                           
    On Error Goto err1
    
    Dim bmp As BITMAP
    Dim bInfo1 As BITMAPINFO256
    Dim bInfo2 As BITMAPINFO256
    Dim FileHeader As BITMAPFILEHEADER
    Dim bArray1() As Byte
    Dim bArray2() As Byte
    Dim nLines As Long
    Dim WidthArray1 As Long
    Dim WidthArray2 As Long
    Dim colStep As Single
    Dim r As Long
    Dim g As Long
    Dim b As Long
    Dim resCol As Byte
    Dim cc As Long
    Dim x As Long
    Dim y As Long
    Dim i As Long
    
    Call GetObject(handle1, Len(bmp), bmp)
    
    Select Case bmp.bmBitsPixel
    Case 24
        ' nothing ;-)
    Case Else
        MsgBox "Quellbild muß 24 Bit Farbtiefe haben"
        ConvBimap_to_Pal = -1
        Exit Function
    End Select
   
    bInfo1.bmiHeader.biHeight = bmp.bmHeight
    bInfo1.bmiHeader.biWidth = bmp.bmWidth
    bInfo1.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo1.bmiHeader.biBitCount = bmp.bmBitsPixel
    bInfo1.bmiHeader.biSize = Len(bInfo1.bmiHeader)
    bInfo1.bmiHeader.biCompression = 0
    
    bInfo2.bmiHeader.biHeight = bmp.bmHeight
    bInfo2.bmiHeader.biWidth = bmp.bmWidth
    bInfo2.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo2.bmiHeader.biBitCount = 8
    bInfo2.bmiHeader.biSize = Len(bInfo2.bmiHeader)
    bInfo2.bmiHeader.biCompression = 0
    
    ' Der 1. Aufruf ohne Übergabe von bArray, dient dazu die Größe
    ' des benötigten Feldes festzustellen. Die Palette wir hier auch
    ' schon übertragen.
    nLines = GetDIBits256(hDC, handle1, 0, bmp.bmHeight, _
                       ByVal 0, bInfo1, DIB_RGB_COLORS)
    
    If nLines = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        ConvBimap_to_Pal = -2 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If
                       
    ' Jetzt können wir die Breite einer Zeile berechnen. Diese ist
    ' nicht notwendigerweise wie erwartet, sondern enthält evtl.
    ' sogenannte Padbytes.
    WidthArray1 = bInfo1.bmiHeader.biSizeImage / bInfo1.bmiHeader.biHeight
    ReDim bArray1(1 To WidthArray1, 1 To bInfo1.bmiHeader.biHeight)
    
    ' Feststellen der Dimensionen der 8Bit-Palettenbitmap
    nLines = GetDIBits256(hDC, handle1, 0, bmp.bmHeight, _
                       ByVal 0, bInfo2, DIB_RGB_COLORS)
    
    If nLines = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        ConvBimap_to_Pal = -3 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If
    
    WidthArray2 = bInfo2.bmiHeader.biSizeImage / bInfo2.bmiHeader.biHeight
    ReDim bArray2(1 To WidthArray2, 1 To bInfo2.bmiHeader.biHeight)
    
    ' Jetzt wird tatsächlich gelesen. Die Bitmapdaten befinden sich
    ' anschließend in bArray und könnten hier auch manipuliert werden.
    nLines = GetDIBits256(hDC, handle1, 0, bmp.bmHeight, _
                        bArray1(1, 1), bInfo1, DIB_RGB_COLORS)
                        
    If nLines = 0 Then
        ConvBimap_to_Pal = -4 ' Tja, dann ist wohl was schiefgelaufen.
        Exit Function
    End If
    
                                  
    bInfo2.bmiHeader.biClrUsed = 256
    bInfo2.bmiHeader.biClrImportant = 256
    
    colStep = 255 / (nSteps - 1)
    Dim k As Long

    
    If col = 7 Then
        For i = 0 To nSteps - 1
            k = i * colStep
            bInfo2.bmiColors(i) = k + k * 256 + k * 65536
        Next i
    Else
        For i = 0 To 255
            bInfo2.bmiColors(i) = 0
        Next i
        Select Case col
            
        Case 1
            cc = 65536
        Case 2
            cc = 256
        Case 4
            cc = 1
        End Select
    
        For i = 0 To nSteps - 1
            k = i * colStep
            bInfo2.bmiColors(i) = bInfo2.bmiColors(i) + k * cc
        Next i
    
    End If
    
    If GreyIn = True Then
        For y = 1 To nLines
            For x = 1 To WidthArray2
                bArray2(x, y) = bArray1(x * 3, y) / colStep
            Next x
        Next y
    Else
        If col = 7 Then
              
            For y = 1 To nLines
                For x = 1 To WidthArray2
                    r = bArray1(x * 3 - 2, y)
                    g = bArray1(x * 3 - 1, y)
                    b = bArray1(x * 3 - 0, y)
                    resCol = (r * 0.222) + (g * 0.707) + (b * 0.071)
                    bArray2(x, y) = resCol / colStep
                Next x
            Next y
            
        Else
        
            Select Case col
            
            Case 1
                cc = 0
            Case 2
                cc = 1
            Case 4
                cc = 2
            End Select
        
            For y = 1 To nLines
                For x = 1 To WidthArray2
                    bArray2(x, y) = bArray1(x * 3 - cc, y) / colStep
                Next x
            Next y
        
        End If
        
    End If
    
    ' Hier wird die konvertierte Bitmap an das handle des Ausgabecontrols
    ' übergeben.
    nLines = SetDIBits256(hDC, handle2, 0, bmp.bmHeight, _
                        bArray2(1, 1), bInfo2, DIB_RGB_COLORS)
                        
                        
    
    Exit Function
    
err1:
    Select Case Err
    
    Case 999
    
    Case Else
        MsgBox Error$
        Resume
    End Select
    
End Function

Function SwapRedBlue(ByVal col As Long) As Long
    
    Dim red As Long, green As Long, blue As Long, newcolor As Long
    red = col And 255
    green = col And 65280
    green = green / 256   '2 ^ 8
    blue = col And 16711680
    blue = blue / 65536 ' 2^16
            
    newcolor = blue + green * 256 + red * 65536
    SwapRedBlue = newcolor
    
End Function


Function ToGreyByPalette(hDC As Long, _
                         handle1 As Long, _
                         handle2 As Long, _
                         ByVal nGreys As Long) As Long

    Dim nLines As Long
    Dim WidthArray As Long
    Dim i As Long
    Dim pal() As Long
    Dim bInfo As BITMAPINFOPAL
    Dim bArray() As Byte
    Dim bmp As BITMAP
    Dim ret As Long
    Dim Oldpal As Long
    Dim LogPal As LOGPALETTE
   
    LogPal.palVersion = &H300
    LogPal.palNumEntries = nGreys
 
    Dim k As Long
    k = LogPal.palNumEntries - 1
    Dim cnt As Long
    cnt = 0
    For i = 0 To k
        LogPal.palPalEntry(i).peRed = i * 255 / k
        LogPal.palPalEntry(i).peGreen = i * 255 / k
        LogPal.palPalEntry(i).peBlue = (i * 255 / k)
    Next i
   
    hPal = CreatePalette(LogPal)
    Oldpal = SelectPalette(hDC, hPal, True)
    ret = RealizePalette(hDC)
        
    Call GetObject(handle1, Len(bmp), bmp)
    
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = 8 'bmp.bmBitsPixel
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0
    bInfo.bmiHeader.biClrUsed = 256
    bInfo.bmiHeader.biClrImportant = 256
 

    nLines = GetDIBitsPAL(hDC, handle1, 0, bmp.bmHeight, ByVal 0, bInfo, DIB_PAL_COLORS)
'    ReDim pal(255)
'    Dim nn As Double
'
'    For i = 0 To 255
'         k = bInfo.bmiColors(i) 'And 255
'
'         pal(i) = LogPal.palPalEntry(k).peRed + _
'                   LogPal.palPalEntry(k).peGreen * 256# + _
'                     LogPal.palPalEntry(k).peBlue * 65536
'
'    Next i
'
'    PaletteF.Show
'    Call PaletteF.setPalette(pal)
'    PaletteF.DisplayPalette
   
    WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
    ReDim bArray(1 To WidthArray, 1 To bInfo.bmiHeader.biHeight)
    nLines = GetDIBitsPAL(hDC, handle1, 0, bmp.bmHeight, bArray(1, 1), bInfo, DIB_PAL_COLORS)
   
    
    'Bild in das Ausgabebild schreiben
    nLines = SetDIBitsPAL(hDC, handle2, 0, bmp.bmHeight, bArray(1, 1), bInfo, DIB_PAL_COLORS)
    
End Function


'---------- Ende Modul "Module1" alias Module1.bas ----------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "optRe" (Index von 1 bis 3) auf Frame1
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Schaltfläche "Command8"
' Steuerelement: Schaltfläche "Command7"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Schaltfläche "Command6"
' Steuerelement: Schaltfläche "Command5"
' Steuerelement: Rahmensteuerelement "Frame2"
' Steuerelement: Optionsfeld-Steuerelement "optImage" (Index von 0 bis 1) auf Frame2
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Public Function GetRes() As Long
    '#########################
    'Einstellungen auslesen
    '#########################
    On Error Resume Next 'Fehler Behandlung
        
    Dim i As Integer
    
    For i = 1 To optRe.UBound
        If optRe(i).Value = True Then
            GetRes = i
            Exit Function
        End If
    Next i
End Function


Sub setCombo(fname As String)
    Dim ext As String
    
    ext = LCase(get_extension(fname))
    
    If ext = "bmp" Or ext$ = "jpg" Or ext = "jpeg" Or ext = "gif" Then
        Combo1.AddItem fname
    End If
End Sub

Private Sub Combo1_Click()
    Picture2.Cls
    Picture2.Picture = LoadPicture("")
    
    If Combo1.ListIndex > 0 Then
        Picture1.Picture = LoadPicture(App.Path + "\bitmaps\" + _
                           Combo1.List(Combo1.ListIndex))
        DoEvents
        Picture2.Move Picture2.Left, Picture2.Top, _
        Picture1.Width, Picture1.Height
        'Picture2.Picture = Picture1.Picture
    End If
End Sub

Private Sub Command5_Click()
    PaletteF.Show
    DoEvents
    Call PaletteF.cmdPalette_Click
End Sub

Private Sub Command2_Click()
    Picture1.Picture = Picture2.Image
End Sub

Private Sub Command3_Click()
    '#########################
    'Bilder wieder löschen(CLS)
    '#########################
    
    Picture1.BackColor = vbWhite 'vbRed
    Picture2.BackColor = vbWhite 'vbRed
    
    Picture1.Picture = LoadPicture("")
    Picture2.Picture = LoadPicture("")
End Sub


Private Sub Command4_Click()
    '#########################
    'Test Bild erstellen
    '#########################
        
    Dim y As Integer
    Dim x As Integer
    
    Picture1.Width = 508 'größe der PictureBox festlegen
    Picture1.Height = 150 'größe der PictureBox festlegen
    Randomize
    For y = 0 To 200 Step 4
        
        Picture1.DrawWidth = Val(Int(Rnd * 30)) + 1
        For x = 0 To 200 Step 4
            Picture1.ForeColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
            Picture1.Line (Int(Rnd * 1000), Int(Rnd * 1000))-(Int(Rnd * 1000), Int(Rnd * 1000))
        Next x
    Next y
    Picture1.Picture = Picture1.Image
End Sub

Private Sub Command6_Click()
    Picture2.Picture = Picture2.Image
End Sub


Private Sub Command7_Click()
   Dim ret As Long
    
    Picture2.Refresh
    Picture2.Width = Picture1.Width
    Picture2.Height = Picture1.Height
    If optImage(0).Value = True Then
        ret = ToGreyByPalette(Picture1.hDC, Picture1.Image, Picture2.Image, VScroll1.Value)
    Else
        ret = ToGreyByPalette(Picture1.hDC, Picture1.Picture, Picture2.Image, VScroll1.Value)
    End If
    
    Picture2.Refresh
End Sub

Private Sub Command8_Click()
    Dim ret As Long
    
    If optImage(0).Value = True Then
        ret = ConvBimap_to_Pal(Picture1.hDC, Picture1.Image, Picture2.Image, VScroll1.Value, 7, 0)
    Else
        ret = ConvBimap_to_Pal(Picture1.hDC, Picture1.Image, Picture2.Image, VScroll1.Value, 7, 0)
    End If
    Picture2.Refresh
End Sub


Private Sub Form_Load()
    Dim test As String
    
    Combo1.AddItem " Bild auswählen"
    Combo1.ListIndex = 0
    test = App.Path + "\bitmaps\*.*"
    test = Dir$(test)
    Call setCombo(test)
    
    Do
        test = Dir$
        Call setCombo(test)
    Loop Until test$ = ""
End Sub


Function get_extension(Title As String) As String

    Dim pos As Integer
    Dim t As String

    For pos = Len(Title) To 1 Step -1

        t = Mid$(Title, pos, 1)
        If t = "." Then
            Exit For
        End If

    Next pos
    
    If pos > 0 Then
        t = Right$(Title, Len(Title) - pos)
    Else
        t = ""
    End If
    
    get_extension = UCase(t)
End Function

Private Sub VScroll1_Change()
    Call Command7_Click
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------ Anfang Formular "PaletteF" alias paletteF.frm  ------
' Steuerelement: Optionsfeld-Steuerelement "Option1" (Index von 0 bis 3)
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "cmdPalette"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label1"


Private cPalette() As Long

Public Function DisplayPalette()
    
    Dim wi As Long
    Dim hei As Long
    Dim xmax As Long
    Dim ymax As Long
    
    xmax = Val(Text1.Text)
    wi = Int((Me.ScaleWidth - 2 * Picture1.Left) / xmax)
    If (256 / xmax) - (256 \ xmax) > 0 Then
        ymax = (256 \ xmax) + 1
    Else
        ymax = (256 \ xmax)
    End If
    hei = (Me.ScaleHeight - Picture1.Top - Picture1.Left) / ymax
    If hei < wi Then
        wi = hei
    Else
        hei = wi
    End If
     
    bo = Picture1.Width - Picture1.ScaleWidth
    Picture1.Width = bo + wi * xmax
    Picture1.Height = bo + hei * ymax
    j = 0
    i = -1
    'Picture1.ForeColor = SwapRedBlue(cPalette(i))
    Picture1.Cls
    Picture1.FillStyle = 0
    For y = 0 To UBound(cPalette)
        For x = 0 To xmax - 1
            i = i + 1
            Picture1.FillColor = (cPalette(i))
            Picture1.Line (x * wi, y * hei)-(x * wi + wi, y * hei + hei), 0, B
            If i = UBound(cPalette) Then
                Goto exi
            End If
        Next x
    Next y
exi:
    
End Function

Public Function setPalette(pal() As Long)
    For i = 0 To 255
        cPalette(i) = SwapRedBlue(pal(i))
    Next i
End Function

Public Sub cmdPalette_Click()
    
    Dim res As Long
    Dim handle As Long
    
    res = Form1.GetRes()
    res = Val(Form1.optRe(res).Tag)
    
    For i = 0 To 3
        If Option1(i).Value = True Then
            Exit For
        End If
    Next i
    Select Case i
    Case 0
        handle = Form1.Picture1.Picture
    Case 1
        handle = Form1.Picture1.Image
    Case 2
        handle = Form1.Picture2.Picture
    Case 3
        handle = Form1.Picture1.Image
    End Select
    
    ' Hier wird die Palette ermittelt, die bei einer
    ' Konversion verwendet werden würde. Falls ein Bitmaphandle
    ' übergeben wird, welches eine Palettenbitmap enthält, wird
    ' diese angezeigt. Ansonsten wird die Systempalette verwendet.
    ret = GetPalette_AllRes(Form1.Picture1.hDC, handle, res, cPalette())
    Picture1.Cls
    If ret >= 0 Then
        Call DisplayPalette
    Else
        'MsgBox "Es konnte keine Palette gelesen werden!"
    End If
    
   
exi:
    'SavePicture Picture1.Image, App.Path + "\Palette256.bmp"

End Sub

Private Sub Form_Load()
    'Call cmdPalette_Click
    ReDim cPalette(255)
End Sub


Private Sub Option1_Click(Index As Integer)
    Call cmdPalette_Click
End Sub

'------- Ende Formular "PaletteF" alias paletteF.frm  -------
'-------------- Ende Projektdatei Project1.vbp --------------