Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0643: Farbtiefe einer PictureBox verändern

VB 5/6-Tipp 0643: Farbtiefe einer PictureBox verändern

 von Udo Schmitt

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, CreateCompatibleDC, CreateDIBSection, OleCreatePictureIndirect (CreatePic), DeleteDC, DeleteObject, GetDC, GetDesktopWindow, GetObjectA, ReleaseDC, SelectObject

Download: Download des Beispielprojektes [5,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 Projekt1.vbp -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Kombinationsliste "Combo1"



' "chgBPP" ändert die BitsPerPixel-Eigenschaft einer PictureBox.
'
' Bilder, die mit LoadPicture in eine PictureBox übertragen
' werden, passen die hierbei von VB benutzten OLE-Funktionen
' der aktuellen Bildschirmeinstellung an.
'
' Damit die Graphik-Tipps funktionieren, muß das Bild i.d.R. im
' 24-Bit-Format vorliegen. Dies wird von der Funktion chgBPP
' umgesetzt, die deshalb vor der eigentlichen Manipulation durch
' die Graphik-Tipp-Funktion ausgeführt werden muss.
'
' Im hiesigen Beispiel wird das Bild von PictureBox1 nach PictureBox2
' kopiert. Für die Anwendung im Zusammenhang mit den Grafik-Tipps
' ist nur Module1 nötig, und muss der Aufruf von chgBPP:
' CALL chgBPP(Picture1, Picture1, 24) lauten.

Option Explicit

' größerer Wert => größere Form
Private Const XYcm      As Long = 567&
Private Const Ftxt      As String = "Change BitsPerPixel"

' udt: Windows-Bitmap-Struktur
'      -> Einlesen der Bildinformationen
'         mit GDI_GetObject()

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

' Einlesen von Informationen über GDI-Objekte (z.B. Bilder)
Private Declare Function GetObjectA Lib "gdi32" _
    (ByVal hObject As Long, _
     ByVal nCount As Long, _
     ByRef lpObject As Any) As Long

Private Sub Combo1_Click()
    Combo1_Change
End Sub

Private Sub Form_Load()
    With Me
        .ScaleMode = vbTwips
        .Width = 12 * XYcm
        .Height = 7 * XYcm
        .Caption = Ftxt
    End With
    
    With Me.Combo1
        .AddItem 1
        .AddItem 4
        .AddItem 8
        .AddItem 16
        .AddItem 24
        .AddItem 32
        .ListIndex = 4
    End With

    Command1.Caption = "Bild laden"
End Sub

Private Sub Form_Resize()
    Dim dfw As Long
    Dim dfh As Long
    Dim tmp As Long
    
    dfw = Me.Width - Me.ScaleWidth
    dfh = Me.Height - Me.ScaleHeight
    tmp = (2 * 6) * XYcm + dfw
    
    If Me.Width < tmp Then Me.Width = tmp
    If Me.Height < 5 * XYcm Then Me.Height = 5 * XYcm
    
    ' Bild laden
    With Command1
        .Top = 0.25 * XYcm
        .Left = 0.25 * XYcm
        .Width = 2 * XYcm
        .Height = Combo1.Height
    End With
    
    ' BPP
    With Combo1
        .Top = 0.25 * XYcm
        .Left = 2.5 * XYcm
        .Width = 2 * XYcm
    End With
    
    With Picture1:
        .Top = Combo1.Height + 0.5 * XYcm
        .Left = 0.25 * XYcm
        .Width = (Me.Width - 0.5 * XYcm - 2 * dfw) / 2
        .Height = Me.Height - .Top - 0.25 * XYcm - dfh
    End With
    
    With Picture2:
        .Top = Picture1.Top
        .Left = Picture1.Width + 0.5 * XYcm
        .Width = Picture1.Width
        .Height = Picture1.Height
    End With
End Sub

Private Sub Form_Activate()
    Call Command1_Click
End Sub

Private Sub Combo1_Change()
    On Error Resume Next
    
    If chgBPP(Me.Picture1, Me.Picture2, Val(Combo1.Text)) Then
        Call shwBPP(Picture2)
    End If
    
    ' Me.Picture1.SetFocus
End Sub

' Bild laden
Private Sub Command1_Click()
    On Error Resume Next
    
    With CommonDialog1
        .CancelError = True
        .Flags = &H281800
        .Filter = "Bilder |*.bmp;*.jpg||"
        .ShowOpen
    
        If Err = 0 Then
            Set Picture1 = LoadPicture(.FileName)
            Call shwBPP(Picture1)
            Call Combo1_Change
        End If
    End With
    
    Me.Picture1.SetFocus
End Sub

Function shwBPP(pbx As PictureBox)
    Dim bmp    As BITMAP
    Dim txt    As String
    Dim I1     As Long
    
    With pbx
        .CurrentX = 0
        .CurrentY = 0
        .FontBold = True
        .ForeColor = vbBlack
        .FontSize = 15
    End With
    
    If GetObjectA(pbx.Picture.Handle, Len(bmp), bmp) <> 0 Then
        txt = "BitsPerPixel " & bmp.bmBitsPixel
    Else
        txt = "Fehler"
    End If
    
    pbx.Print txt
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------


' ---------------------------------------------------
' DateTime  : 16.10.2003
' Author    : (softKUS)
' ---------------------------------------------------

Option Explicit

Private Const S_OK As Long = 0
Private Const BI_RGB As Long = 0
Private Const DIB_RGB_COLORS As Long = 0
Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

' udt: Windows-Bitmap-Struktur
'      -> Einlesen der Bildinformationen
'         mit GDI_GetObject()
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

' udt: Windows-Bitmap-Struktur
'      -> Erstellen von Bildern im Speicher,
'         mit GDI_CreateDibSection
'      -> Einlesen von Bilddaten (binär)
'         mit GDI_GetDiBits
'
'      wird nur als Unterstruktur von
'      BITMAPINFO benötigt (s.u.)
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

' udt: Windows-Bitmap-Struktur
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As Long
End Type

' udt: PictureDescription
'      -> Erstellen eines IPicture-Objektes
'         mit OleCreatePictureIndirect
Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type


' GDI (graphical device interface)

' Handle auf Fenster-Gerätekontext
Private Declare Function GetDC Lib "user32" _
    (ByVal hWnd As Long) As Long
    
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long

' Freigeben eines Gerätekontextes
Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hWnd As Long, _
     ByVal hdc As Long) As Long
        
' Erstellen eines kompatiblen Gerätekontextes
Private Declare Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hdc As Long) As Long

' Löschen eines Gerätekontextes
Private Declare Function DeleteDC Lib "gdi32" _
    (ByVal hdc As Long) As Long

' Einlesen von Informationen über GDI-Objekte (z.B. Bilder)
Private Declare Function GetObjectA Lib "gdi32" _
    (ByVal hObject As Long, _
     ByVal nCount As Long, _
     ByRef lpObject As Any) As Long

' Erstellen eines geräte-unabhängigen Bildes (Device Independent Bitmap, DIB)
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hdc As Long, _
     ByRef pbmi As BITMAPINFO, _
     ByVal iUsage As Long, _
     ByRef ppvBits As Long, _
     ByVal hSection As Long, _
     ByVal dwOffset As Long) As Long

' Selektieren eines GDI-Objektes
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, _
     ByVal hObject As Long) As Long

' Löschen eines GDI-Objektes
Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long


' OLE (Object Linked Embedding, heute: COM oder ActiveX genannt)

' Umwandeln eines CLSID-Strings in Binärcode
Private Declare Function CLSIDFromString Lib "ole32" _
    (ByVal lpszProgID As Long, _
     ByVal pCLSID As Long) As Long

' Erstellen eines IPicture-Objektes aus einem GDI-Bitmap-Handle
Private Declare Function CreatePic Lib "olepro32" Alias "OleCreatePictureIndirect" _
    (ByRef lpPictDesc As PictDesc, _
     ByVal riid As Long, _
     ByVal fPictureOwnsHandle As Long, _
     ByRef ipic As IPicture) As Long

Function chgBPP(src As PictureBox, tgt As PictureBox, _
                Optional BPP As Long = 24, Optional etx As String) As Boolean
    
    Dim pic As StdPicture
    Dim bmp As BITMAP
    Dim bmi As BITMAPINFO
    Dim dsc As PictDesc
    Dim hD1 As Long
    Dim hD2 As Long
    Dim hSV As Long
    Dim ptr As Long
    Dim iid(15) As Byte
    
    If src.Picture.Handle = 0 Then
        etx = "Kein Bild geladen"
        
    ElseIf GetObjectA(src.Picture.Handle, Len(bmp), bmp) = 0 Then
        etx = "Bilddaten konnten nicht gelesen werden"
        
    Else
        ' per OLE-Funktion ein neues IPicture-Objekt erstellen
        dsc.cbSizeofStruct = Len(dsc)
        dsc.picType = vbPicTypeBitmap
        
        With bmi.bmiHeader
            .biSize = Len(bmi.bmiHeader)
            .biCompression = BI_RGB
            .biBitCount = BPP
            .biHeight = bmp.bmHeight
            .biWidth = bmp.bmWidth
            .biPlanes = 1
            .biSizeImage = ((.biWidth * BPP / 8 + 3) And -4) * .biHeight
    
            ' 1. Gerätekontext
            hD1 = GetDC(GetDesktopWindow)
            If hD1 <> 0 Then hD2 = CreateCompatibleDC(hD1)
            
            ' 2. DIB-Section
            If hD2 <> 0 Then dsc.hImage = CreateDIBSection _
                (hD2, bmi, DIB_RGB_COLORS, ptr, 0, 0)
        
            If hD2 = 0 Then
                etx = "Gerätekontext konnte nicht erzeugt werden"
            
            ElseIf dsc.hImage = 0 Or ptr = 0 Then
                etx = "Bildkopie konnte nicht erstellt werden"
            
            ' 3. IPicture-Objekt
            ElseIf CLSIDFromString(StrPtr(IID_IPicture), VarPtr(iid(0))) _
                <> S_OK Then
                
                etx = "OLE Fehler"
                
            Else
                hSV = SelectObject(hD2, dsc.hImage)
                Call src.Picture.Render( _
                    CLng(hD2), _
                    CLng(0), CLng(.biHeight - 1), _
                    CLng(.biWidth), CLng(Not .biHeight), _
                    0, 1 / (0.567 / Screen.TwipsPerPixelY), _
                    src.Picture.Width, src.Picture.Height, 0&)
                
                Call SelectObject(hD2, hSV)
            
                If CreatePic(dsc, VarPtr(iid(0)), True, pic) <> S_OK Then
                    etx = "OLE picture creation error"
                            
                Else
                    Set tgt.Picture = Nothing
                    Set tgt.Picture = pic
                    dsc.hImage = 0
                    chgBPP = True
                End If
            End If
        End With
    End If
    
    If dsc.hImage Then Call DeleteObject(dsc.hImage)
    
    If hD2 Then Call DeleteDC(hD2)
    If hD1 Then Call ReleaseDC(GetDesktopWindow, hD1)
End Function

'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------