Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0517: Farbtiefe einer Bitmap ändern

VB 5/6-Tipp 0517: Farbtiefe einer Bitmap ändern

 von Klaus Langbein

Schwierigkeitsgrad:

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

Download: Download des Beispielprojektes [272,44 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
        
Private 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
         
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

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 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$, _
                           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 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: 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: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "optRe" (Index von 1 bis 6) auf Frame1
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
' 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$)

    Dim ext$
    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
    End If

End Sub

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

Private Sub Command1_Click()
    
    Dim res As Long '
    Dim ret As Long
    Dim palette As Variant
    Picture2.Picture = LoadPicture("")
    Picture2.Cls
    
    res = GetRes()
    res = Val(optRe(res).Tag)
    
    ' Wichtig! Die Picturebox für die Ausgabe muß die gleichen Dimensionen haben.
    Picture2.Move Picture2.Left, Picture2.Top, Picture1.Width, Picture1.Height
    
    If optImage(0).Value = True Then
        ret = ConvBitmap_AllRes(Picture1.hdc, Picture1.Image, Picture2.Image, res)
    Else
        ret = ConvBitmap_AllRes(Picture1.hdc, Picture1.Picture, Picture2.Image, res)
    End If
    
    Picture1.Refresh
    Picture2.Refresh
    
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
    Picture1.Picture = Picture1.Image
End Sub

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


Private Sub Form_Load()

    Dim test$
    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

    Dim pos As Integer
    Dim t$

    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
'---------- 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"
Dim 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 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
End Sub


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

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

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.