Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0493: Bitmaps in verschiedenen Farbtiefen speichern

VB 5/6-Tipp 0493: Bitmaps in verschiedenen Farbtiefen speichern

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetDIBits, GetDIBits (GetDIBits256), GetObjectA (GetObject)

Download: Download des Beispielprojektes [38,73 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 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 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



Function SaveBitmap_AllRes(hDc As Long, handle As Long, _
                           ByVal BitsPerPixel As Long, _
                           ByVal fName$, _
                           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 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


'---------- Ende Modul "Module1" alias Module1.bas ----------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Rahmensteuerelement "Frame3"
' Steuerelement: Textfeld "txtCol2" (Index von 0 bis 2) auf Frame3
' Steuerelement: Textfeld "txtCol1" (Index von 0 bis 2) auf Frame3
' Steuerelement: Figur-Steuerelement "Shape2" auf Frame3
' Steuerelement: Figur-Steuerelement "Shape1" auf Frame3
' Steuerelement: Beschriftungsfeld "Label6" auf Frame3
' Steuerelement: Beschriftungsfeld "Label5" auf Frame3
' Steuerelement: Rahmensteuerelement "Frame2"
' Steuerelement: Optionsfeld-Steuerelement "optImage" (Index von 0 bis 1) auf Frame2
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "optRe" (Index von 1 bis 6) auf Frame1
' Steuerelement: Schaltfläche "Command2" (Index von 0 bis 1)
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit
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


Private Sub Form_Load()

End Sub

Private Sub txtCol1_Change(Index As Integer)

    '#########################
    'Farben für Palette erstellen
    '#########################
    
    Shape1.FillColor = RGB(Val(txtCol1(0).Text), Val(txtCol1(1).Text), Val(txtCol1(2).Text))
    'RGB steht für Rot Grün Blau
    '(Red Green Blue) durch diese
    'Funktion kann man Farben leicht kreieren
    
End Sub

Private Sub txtCol2_Change(Index As Integer)
    '#########################
    'Farben für Palette stellen
    '#########################

    Shape2.FillColor = RGB(Val(txtCol2(0).Text), Val(txtCol2(1).Text), Val(txtCol2(2).Text))
    'RGB steht für Rot Grün Blau
    '(Red Green Blue) durch diese
    'Funktion kann man Farben leicht kreieren
End Sub

Private Sub Command1_Click()

    '#########################
    'Bildee speichern & anzeigen
    '#########################
    On Error Goto err1 'Fehlerbehandlung
    
    Dim Palette As Variant
    Dim fName As String
    Dim Vorhanden As String
    Dim Ret As Long
    Dim Res As Long
    
    fName = App.Path + "\temp.bmp"
    Vorhanden = Dir$(fName)
    If Vorhanden <> "" Then
        Kill fName
    End If
    
    Picture2.Picture = LoadPicture("") 'Bild löschen
    Picture2.Cls
    
    ReDim Palette(1) 'Palette "reservieren"
    Palette(0) = Shape1.FillColor 'In diesem Fall einlesen von der Oberfläche!
    Palette(1) = Shape2.FillColor
    ' Eine kleine Spielerei: wenn man eine Palette mit 2
    ' Einträgen übergibt, wirds nicht Schwarz/Weis, sondern
    ' zb Gelb/Blau
    ' Die Übergabe der Palette ist optional
    
    Res = GetRes()
    Res = Val(optRe(Res).Tag)
    If optImage(0).Value = True Then
        Ret = SaveBitmap_AllRes(Picture1.hDc, Picture1.Image, Res, fName$, Palette)
    Else
        Picture1.Picture = Picture1.Image 'Es muß natürlich was da sein...
        Ret = SaveBitmap_AllRes(Picture1.hDc, Picture1.Picture, Res, fName$, Palette)
    End If
    
    Label4.Caption = "-"
    
    If Ret > 0 Then
        Picture2.Picture = LoadPicture(fName) 'gespeichertes Bild laden
        Label4.Caption = Format$(Ret) 'Dateiengröße ausgeben
    Else
        'Wenn ret kleiner 0 ist, hat die Funktion SaveBitmap_AllRes
        ' einen Fehlerwert zurückgeliefert
        MsgBox "Fehler beim Speichern von Bitmap!"
    End If
    
    Exit Sub
    
err1:
    
    Select Case Err
    
    Case Else
        MsgBox Error$
    End Select
    
    
End Sub


Private Sub Command2_Click(Index As Integer)
    '#########################
    'TestBild laden
    '#########################
    On Error Resume Next 'Fehler Behandlung
    
    Dim fName As String
    
    Select Case Index
    Case 0
        fName = App.Path + "\AVBBild_24Bit.gif"
    Case 1
        fName = App.Path + "\rainbow.bmp"
    End Select
    Picture1.AutoSize = True
    Picture1.Picture = LoadPicture(fName)
    
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
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.