Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0627: Grundfarbe, Sättigung und Helligkeit in Grafiken ändern per ASM

 von 

Beschreibung 

Dieser Tipp stammt aus eine Reihe von Tipps rund um das Thema Grafikmanipulation mit ASM. Das Modul "asm_001ROU.bas" ist daher in allen Tipps das Gleiche. In diesem Tipp wird gezeigt, wie man die HSL-Werte eines Bildes ändert. Dabei wird sowohl eine Lösung mit VB, wie auch eine Lösung in ASM (der Code liegt bei) angeboten.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

CLSIDFromString, CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), CreateDIBSection, OleCreatePictureIndirect (CreatePic), DeleteObject, GetDC, GetDIBits, GetObjectA (GetObject), ReleaseDC

Download:

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

'--- Anfang Formular "frm_ChangeHSL" alias frm_ChangeHSL.frm  ---
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"



'---------------------------------------------------------------------------------------
' (softKUS) - VIII/2003
'---------------------------------------------------------------------------------------
' Die Funktion "ChangeHSL" änder Grundfarbe, Sättigung und Helligkeit.
'
' Für die Umsetzung wird eine Assembler-(Maschinensprache)-Routine benutzt,
' deren Funktionsweise nicht ohne weiteres ersichtlich ist. Deshalb ist eine
' Basic-Funktion, basChangeHSL, angefügt. Per Mausklick auf Command3 kann
' zwischen Basic- und Assemblerbenutzung hin- und hergeschaltet werden.
'
' Das Beispiel besteht aus drei Modulen:
' 1. Form1    - Dient bloß zur Demonstration
' 2. Module1  - Enthält grundlegendes zum Lesen/Schreiben der Bilder
' 3. Module2  - Enthält die eigentliche Bildbearbeitung (asmChangeHSL/basChangeHSL)
'
' Die ASM-Routine, asmChangeHSL, kann auch völlig losgelöst vom hiesigen Rahmen
' benutzt werden. Es muß lediglich gewährleistet sein, daß der erste Parameter
' (lpAsmBmpPara) auf eine genau nach unten beschriebenem Muster erstellte und
' mit gültigen Werten initialisierte Struktur verweist - andernfalls kommt
'     es
' garantiert zum PC-Absturz.
'
'---------------------------------------------------------------------------------------
'
' Ein Formular mit:
' Picture1, Command1 bis Command3, HScroll1, CommonDialog1, Combo1
'
'---------------------------------------------------------------------------------------

Option Explicit
Option Base 0

' *
' **
' *** Konstanten
' *** - für die Bildbearbeitung sind nur die Parameter für die Bildlaufleiste
' ***   interessant (HPar): Min;Max;(Standard-)Value;SmallChange;LargeChange
' **
' *

' größerer Wert => größere Form
Private Const XYcm      As Long = 567
Private Const Ftxt      As String = "asm-Beispiel ChangeHSL"
Private Const HPar      As String = "00000;00255;00000;00001;00010;00" & _
     "000;0" & "0235;00118;00001;00025;-0255;00255;00000;00001;00010"


' *
' **
' *** Variablen
' **
' *

' log: Bildlaufleiste aktiv J/N
Dim scrH_flg            As Boolean

' lng: Bildlaufleisten-Standardwert
Dim scrH_std            As Long

' udt: Datenstruktur für ASM-Routine
Dim abp                 As asmBmpPara

' bin: Bilddaten
Dim src()               As Byte

' bin: Puffer für die Bildbearbeitung
Dim tgt()               As Byte

' log: .T.=Assember, .F.=Basic
Dim pmd                 As Boolean

Private Sub Form_Load()
    
    ' Initialisieren der Byte-Arrays
    ReDim src(1, 1)
    
    ' (vermeidet Zugriffsfehler)
    ReDim tgt(1, 1)
    
    With Me
        .ScaleMode = vbTwips
        .Width = (Me.Controls.Count * 2 - 2) * XYcm
        .Height = (Me.Controls.Count * 2 - 2) * XYcm
        .Caption = Ftxt
    End With
    
    With HScroll1
        .min = Val(Mid$(HPar, 1, 5))
        .max = Val(Mid$(HPar, 7, 5))
        .Value = Val(Mid$(HPar, 13, 5))
        .SmallChange = Val(Mid$(HPar, 19, 5))
        .LargeChange = Val(Mid$(HPar, 25, 5))
        scrH_std = .Value
    End With
    
    With Combo1
        .AddItem "Hue"
        .AddItem "Saturation"
        .AddItem "Lightness"
        .ListIndex = 0
    End With
    
    Command1.Caption = "Bild laden"
    Command2.Caption = "Undo"
    Command3.Caption = "Basic"
    Picture1.ScaleMode = vbTwips
    
    pmd = True
End Sub

' dummy Bild erzeugen
Private Sub Form_Initialize()
    Dim X1 As Long
    
    Randomize Timer
    Picture1.AutoRedraw = True
    
    For X1 = 1 To 400
        Picture1.DrawWidth = 1 + Rnd() * 30
        Picture1.Line (Rnd * Picture1.Width, Rnd * Picture1.Height)-(Rnd * Picture1.Width, _
            Rnd * Picture1.Height), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
        
    Next X1
    
    Picture1.AutoRedraw = False
    
    scrH_flg = ReadData(Picture1.Image, abp, src, tgt, pmd, False)
    If scrH_flg Then WriteData Picture1, abp.src, True
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 = ((Me.Controls.Count - 3) * 2.25 + 0.25) * XYcm + dfw
    
    If Me.Width < tmp Then Me.Width = tmp
    If Me.Height < 5 * XYcm Then Me.Height = 5 * XYcm
    
    With Command1
        
        ' Bild laden
        .Top = 0.25 * XYcm
        .Left = 0.25 * XYcm
        .Width = 2 * XYcm
        .Height = 0.5 * XYcm
    End With
    
    With Combo1
        
        ' Mode
        .Top = 0.25 * XYcm
        .Left = 2.5 * XYcm
        .Width = 2 * XYcm
    End With
    
    With Command2
        
        ' Undo
        .Top = 0.25 * XYcm
        .Left = Me.Width - 4.5 * XYcm - dfw
        .Width = 2 * XYcm
        .Height = 0.5 * XYcm
    End With
    
    With Command3
        
        ' bas/asm
        .Top = 0.25 * XYcm
        .Left = Me.Width - 2.25 * XYcm - dfw
        .Width = 2 * XYcm
        .Height = 0.5 * XYcm
    End With
    
    
    With Picture1
        .Top = 1 * XYcm
        .Left = 0.25 * XYcm
        .Width = Me.Width - 0.5 * XYcm - dfw
        .Height = Me.Height - 2 * XYcm - dfh
    End With
    
    With HScroll1
        .Top = Picture1.Top + Picture1.Height + 0.25 * XYcm
        .Left = 0.25 * XYcm
        .Width = Picture1.Width
        .Height = 0.5 * XYcm
    End With
End Sub

Private Sub Picture1_DblClick()
    Form_Initialize
End Sub

' Bild laden
Private Sub Command1_Click()
    
    ' obj: enthält das zu ladende Bild
    Dim pic As IPicture
    
    On Error Resume Next
    
    With CommonDialog1
        .CancelError = True
        .Flags = &H281800
        .Filter = "Bilder |*.bmp;*.jpg||"
        .ShowOpen
        
        If Err = 0 Then
            Set pic = LoadPicture(.FileName)
            
            If pic Is Nothing Then
                MsgBox "Bild konnte nicht geladen werden"
                
            ElseIf ReadData(pic, abp, src, tgt, pmd) Then
                
                ' alles okay => setze pic auf die PictureBox
                Set Picture1.Picture = pic
                
                ' setze HScroll1 auf den Standardwert
                Command2_Click
                scrH_flg = True
            End If
        End If
    End With
    
    Picture1.SetFocus
End Sub

' Undo
Private Sub Command2_Click()
    
    ' Bildlaufleiste deaktivieren
    scrH_flg = False
    
    ' Änderung am Bild zurücknehmen
    WriteData Picture1, abp.src
    
    ' Bildlaufleiste auf Ausgangswert
    HScroll1 = scrH_std
    
    ' Bildlaufleiste aktivieren
    scrH_flg = True
    Picture1.SetFocus
End Sub

' Umschalten zw. bas und asm
Private Sub Command3_Click()
    pmd = Not pmd
    Command3.Caption = Choose(pmd + 2, "Basic", "Assembler")
    
    If pmd = False And Picture1.Picture.Handle <> 0 And VarPtr(tgt(1, 1)) <> abp.tgt.bmBits _
        Then
        
        ' Wenn abp.tgt direkt auf den Speicher der Bitmap
        ' weist, muss für die Basic-Routine auf ein ByteArray
        ' umgelenkt werden. Dazu kann auch mit einer SAVEARRAY-
        ' Struktur gearbeitet werden - das führte hier aber zu weit.
        
        ReDim tgt(1 To UBound(src, 1), 1 To UBound(src, 2))
        abp.tgt.bmBits = VarPtr(tgt(1, 1))
    End If
    
    Picture1.SetFocus
End Sub

Private Sub Combo1_Click()
    HScroll1_Change
End Sub

Private Sub HScroll1_Scroll()
    HScroll1_Change
End Sub

Private Sub HScroll1_Change()
    Dim H1 As Single
    Dim S1 As Single
    Dim L1 As Single
    Dim B1 As Boolean
    
    If scrH_flg = False Or Picture1.Picture.Handle = 0 Then
        
        ' deaktiviert/kein Bild geladen => ignorieren
        
    Else
        H1 = -1
        S1 = -1
        L1 = -1
        
        Select Case Combo1.ListIndex
        Case 0
            H1 = 6# * HScroll1 / HScroll1.max
        Case 1
            S1 = HScroll1 / HScroll1.max
        Case 2
            L1 = 1 + HScroll1 * (2 + Sgn(HScroll1)) / HScroll1.max
        End Select
        
        If pmd Then
            B1 = asmChangeHSL(VarPtr(abp), H1, S1, L1)
            
        Else
            B1 = basChangeHSL(src, tgt, H1, S1, L1)
        End If
        
        ' geändertes Bild ausgeben
        
        If B1 Then WriteData Picture1, abp.tgt
    End If
End Sub
'--- Ende Formular "frm_ChangeHSL" alias frm_ChangeHSL.frm  ---
'--- Anfang Modul "asm_ChangeHSL" alias asm_ChangeHSL.bas ---

Option Explicit

' asmChangeHSL
'
' CALL          asmChangeHSL(ptr:lpAsmBmpPara, [HV], [SV], [LV])
'
' IN:           lng:ptr Points to asmBmpPara-structure
'               sgl:HV  Hue-Value: <0 = ignore (default)
'                                 >=0 = 0 to 255
'               sgl:SV  Satuation: <0 = ignore (default)
'                                 >=0 = set absolut
'               sgl:LV  Lightness: <0 = ignore (default)
'                                 >=0 = percentage to multiply with
'
' Remarks:      internally, the asm-function works with longs;
'               in order to simulate decimals, all parameters
'               are multiplied with 2^20 (&H100000)
'
' OUT:          bol     success
'
Function asmChangeHSL(lpAsmBmpPara As Long, _
    Optional ByVal HV As Single = -1, _
    Optional ByVal SV As Single = -1, _
    Optional ByVal LV As Single = -1) As Boolean
    
    Static asm(100) As Long

    If asm(0) = 0 Then
        asm(0) = &HEC8B5590:  asm(1) = &H68575653:  asm(2) = &H100000:    asm(3) = &H8B085D8B
        asm(4) = &H7B8B1473:  asm(5) = &H1C4B8B2C:  asm(6) = &H204BAF0F:  asm(7) = &H8BDB3351
        asm(8) = &HC88AACCB:  asm(9) = &H38ACD88A:  asm(10) = &H860272C3: asm(11) = &HACC88AC3
        asm(12) = &H272C338:  asm(13) = &HC138D88A: asm(14) = &HC88A0273: asm(15) = &H348D5756
        asm(16) = &H2BF98B0B: asm(17) = &H105D8BFB: asm(18) = &H2079DB0B: asm(19) = &HFB81DE8B
        asm(20) = &HFF:       asm(21) = &HEB810872: asm(22) = &H1FE:      asm(23) = &HDB0BDBF7
        asm(24) = &HC78B0A74: asm(25) = &H9914E0C1: asm(26) = &HD88BF3F7: asm(27) = &HE0C1C68B
        asm(28) = &HFFBE9913: asm(29) = &HF7000000: asm(30) = &HF0758BF6: asm(31) = &H801745F6
        asm(32) = &H65F70575: asm(33) = &H96F6F714: asm(34) = &H276F03B:  asm(35) = &HDB0BF08B
        asm(36) = &HC68B0975: asm(37) = &HADE9DE8B: asm(38) = &H81000000: asm(39) = &H80000FE
        asm(40) = &H2B0D7200: asm(41) = &HF7E3F7C6: asm(42) = &HC62BF075: asm(43) = &H7EBD8F7
        asm(44) = &HE6F7C32B: asm(45) = &H8BF075F7: asm(46) = &H2BE6D1D8: asm(47) = &HC458BF3
        asm(48) = &H5779C00B: asm(49) = &H775FF0B:  asm(50) = &HD133048D: asm(51) = &H8B4CEBE8
        asm(52) = &HC033E855: asm(53) = &H75FD4A3A: asm(54) = &HFE428A11: asm(55) = &HF74C838
        asm(56) = &H2AF04D8B: asm(57) = &H2772FF42: asm(58) = &H4A3A29EB: asm(59) = &H8A1375FE
        asm(60) = &HC838FF42: asm(61) = &HB90C74:   asm(62) = &H2A003000: asm(63) = &HF72FD42
        asm(64) = &H428A11EB: asm(65) = &HB9FD&:    asm(66) = &H422A0050: asm(67) = &HF60473FE
        asm(68) = &H99D8F7D8: asm(69) = &HF7F06DF7: asm(70) = &H8BC103FF: asm(71) = &HC88BF07D
        asm(72) = &HFFFFF25:  asm(73) = &H15C9C100: asm(74) = &HC72B0472: asm(75) = &HD68BD8F7
        asm(76) = &HE2F7D32B: asm(77) = &HC303F7F7: asm(78) = &H173E1D1:  asm(79) = &H2F98093
        asm(80) = &H93960674: asm(81) = &H93960273: asm(82) = &HFFB95F:   asm(83) = &HE1F70000
        asm(84) = &H8314E8C1: asm(85) = &HC13B00D0: asm(86) = &HC18A0276: asm(87) = &HF7C68BAA
        asm(88) = &H14E8C1E1: asm(89) = &H3B00D083: asm(90) = &H8A0276C1: asm(91) = &HC38BAAC1
        asm(92) = &HE8C1E1F7: asm(93) = &HD08314:   asm(94) = &H276C13B:  asm(95) = &H5EAAC18B
        asm(96) = &HF49A459:  asm(97) = &HFFFE9385: asm(98) = &H1B58F9FF: asm(99) = &H5B5E5FC0
        asm(100) = &H10C25D
    End If

    ' ************************************************************

    If HV >= 0 Then HV = HV * &H100000
    If SV >= 0 Then SV = SV * &H100000
    If LV >= 0 Then LV = LV * &H100000
    
    asmChangeHSL = CallWindowProc(asm(0), lpAsmBmpPara, CLng(HV), CLng(SV), CLng(LV))
End Function

' basRGB2HSL    Convert RGB to HSL
'
' CALL:         basRGB2HSL(R, G, B, @H, @S, @L)
'
' IN:           lng:R   red
'               lng:G   green
'               lng:B   blue
'
' OUT:          sgl:H   hue
'               sgl:S   saturation
'               sgl:L   lightness
'
Public Function basRGB2HSL(R As Byte, G As Byte, B As Byte, _
    h As Single, S As Single, l As Single)
    
    Dim max     As Single
    Dim min     As Single
    Dim dif     As Single
    Dim sum     As Single
    Dim svR     As Single
    Dim svG     As Single
    Dim svB     As Single

    svR = R / 255
    svG = G / 255
    svB = B / 255

    max = svR
    If max < svG Then max = svG
    If max < svB Then max = svB
    
    min = svR
    If min > svG Then min = svG
    If min > svB Then min = svB
    
    sum = max + min
    dif = max - min
    
    h = 0
    S = 0
    l = sum / 2

    If dif Then
        If l > 0.5 Then
            S = dif / (2 - sum)
        Else
            S = dif / sum
        End If
            
        Select Case max
            Case svR: h = 0 + (svG - svB) / dif
            Case svG: h = 2 + (svB - svR) / dif
            Case svB: h = 4 + (svR - svG) / dif
        End Select
      End If
End Function

' basChangeHSL
'
' AUFRUF:       basChangeHSL(src, tgt, [HV], [SV], [LV])
'
' EIN:          sgl:HV  Hue-Value: <0 = ignorieren (Vorgabe)
'                                 >=0 = absolut setzen
'               sgl:SV  Satuation: <0 = ignorieren (Vorgabe)
'                                 >=0 = absolut setzen
'               sgl:LV  Lightness: <0 = ignorieren (Vorgabe)
'                                 >=0 = Mit Prozentsatz multiplizieren
'
' AUS:          log     Erfolg
'
Function basChangeHSL(src() As Byte, tgt() As Byte, _
    Optional HValue As Single = -1, _
    Optional SValue As Single = -1, _
    Optional LFactor As Single = -1) As Boolean
    
    Dim X1  As Long
    Dim Y1  As Long
    Dim H1  As Single
    Dim S1  As Single
    Dim L1  As Single
    Dim R   As Long
    Dim G   As Long
    Dim B   As Long
    
    For X1 = 1 To UBound(src, 1) Step 4
        For Y1 = 1 To UBound(src, 2)
            basRGB2HSL src(X1 + 0, Y1), _
                       src(X1 + 1, Y1), _
                       src(X1 + 2, Y1), _
                       H1, S1, L1
            
            If HValue >= 0 Then H1 = HValue - 1
            If SValue >= 0 Then S1 = SValue
            If LFactor >= 0 Then L1 = L1 * LFactor: If L1 > 1 Then L1 = 1
                            
            basHSL2RGB H1, S1, L1, _
                       tgt(X1 + 0, Y1), _
                       tgt(X1 + 1, Y1), _
                       tgt(X1 + 2, Y1)
        Next
    Next
    
    basChangeHSL = True
End Function

' basHSL2RGB    Convert HSL to RGB
'
' CALL:         basRGB2HSL(H, S, L, @R, @G, @B)
'
' IN:           sgl:H   hue
'               sgl:S   saturation
'               sgl:L   lightness
'
' OUT:          lng:R   red
'               lng:G   green
'               lng:B   blue
'
Public Function basHSL2RGB(h As Single, S As Single, l As Single, _
    R As Byte, G As Byte, B As Byte) As Long
    
    Dim svR As Single
    Dim svG As Single
    Dim svB As Single
    Dim min As Single
    Dim max As Single
    Dim dif As Single
    
    If S = 0 Then
        svR = l
        svG = l
        svB = l
        
    Else
        If l > 0.5 Then
            min = l - S * (1 - l)
        Else
            min = l * (1 - S)
        End If
      
        max = 2 * l - min
        dif = max - min
        
        Select Case h
            Case Is < 0: svR = max: svG = min: svB = min - (h * dif)
            Case Is < 1: svR = max: svB = min: svG = min + (h * dif)
            Case Is < 2: svG = max: svB = min: svR = min + (2 - h) * dif
            Case Is < 3: svG = max: svR = min: svB = min + (h - 2) * dif
            Case Is < 4: svB = max: svR = min: svG = min + (4 - h) * dif
            Case Else:   svB = max: svG = min: svR = min + (h - 4) * dif
        End Select
    End If
   
    svR = svR * 255: If svR > 255 Then svR = 255
    svG = svG * 255: If svG > 255 Then svG = 255
    svB = svB * 255: If svB > 255 Then svB = 255

    R = IIf(svR < 0, 0, svR)
    G = svG
    B = svB
End Function
'---- Ende Modul "asm_ChangeHSL" alias asm_ChangeHSL.bas ----
'------ Anfang Modul "asm_001ROU" alias asm_001ROU.bas ------

Option Explicit
Option Base 0

' *
' **
' *** Konstanten
' **
' *

' gdi/ole
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-00AA00300" & _
    "CAB}"



' *
' **
' *** Strukturen
' **
' *

' Windows-Standard
' udt: Windows-Bitmap-Struktur
Public Type BITMAP
    
    '-> Einlesen der Bildinformationen
    'mit GDI_GetObject()
    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
Public Type BITMAPINFOHEADER
    
    '-> Erstellen von Bildern im Speicher,
    'mit GDI_CreateDibSection
    biSize                      As Long
    biWidth                     As Long
    biHeight                    As Long
    
    '-> Einlesen von Bilddaten (binär)
    'mit GDI_GetDiBits
    biPlanes                    As Integer
    biBitCount                  As Integer      '
    
    'wird nur als Unterstruktur von
    'BITMAPINFO benötigt (s.u.)
    biCompression               As Long
    biSizeImage                 As Long
    biXPelsPerMeter             As Long
    biYPelsPerMeter             As Long
    biClrUsed                   As Long
    biClrImportant              As Long
End Type

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

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


' von asm-Routinen genutzte Struktur
' udt: AsmStruktur
Public Type asmBmpPara
    
    '-> fasst Infos über Herkunftsdaten
    'und Zieldaten zusammen
    'dient vor allem dazu, die Anzahl
    'der Funktionsparamter zu begrenzen
    src                         As BITMAP
    tgt                         As BITMAP
    srcExpansion                As Long
End Type


' *
' **
' *** Externe Funktionen
' **
' *

' div

' hiermit werden Daten recht schnell kopiert
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest _
    As Any, ByRef hpvSource As Any, ByVal cbCopy As Long)


' hiermit wird die asm-Routine aufgerufen
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
    (ByRef lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal _
    wParam As Long, ByVal lParam As Long) As Long



' GDI (graphical device interface)

' Erstellen eines Gerätekontextes
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) _
    As Long


' Freigeben eines Gerätekontextes
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd _
    As Long, ByVal hDC As Long) As Long


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


' Löschen eines GDI-Objektes
Private Declare Function DeleteObject Lib "gdi32" (ByVal _
    hObject As Long) 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


' Einlesen binärer Bilddaten
Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC _
    As Long, ByVal hBM As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, _
    ByRef lpvBits As Any, ByRef lpBmi As BITMAPINFO, ByVal uUsage 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 ReadData(pic As IPicture, abp As asmBmpPara, src() As Byte, tgt() As Byte, _
    Optional pmd As Boolean = True, Optional eMD As Boolean = True) As Boolean

    
    ' infos über das einzulesende Bild
    Dim bmp   As BITMAP
    
    ' erweiterte infos über das einzulesende Bild
    Dim bmi   As BITMAPINFO
    
    ' Gerätekontext-Handle
    Dim hDC   As Long
    
    ' Zeiger auf die binären Bilddaten
    Dim ptr   As Long
    Dim tmp   As Long
    
    ' Einlesen der Bitmapinfos
    If GetObject(pic.Handle, Len(bmp), bmp) = 0 Then
        If eMD Then MsgBox "Bildinformationen konnten nicht gelesen werden"
        
    ElseIf pmd = True And bmp.bmBits <> 0 And bmp.bmBitsPixel = 32 Then
        
        ' wenn die Daten im richtigen Format vorliegen, diesen Pointer nehmen
        ptr = bmp.bmBits
        
    Else
        
        ' sonst per GDI-Funktion konvertieren lassen und im tgt-bArray() speichern
        With bmi.bmiHeader
            .biSize = Len(bmi.bmiHeader)
            .biCompression = BI_RGB
            .biHeight = bmp.bmHeight
            .biWidth = bmp.bmWidth
            .biPlanes = 1
            .biBitCount = 32
            .biSizeImage = .biWidth * 4 * .biHeight
            
            ReDim tgt(1 To .biWidth * 4, 1 To .biHeight)
            hDC = GetDC(0)
            
            If hDC = 0 Then
                If eMD Then MsgBox "Gerätekontext konnte nicht erzeugt werden"
                
            ElseIf GetDIBits(hDC, pic.Handle, 0, .biHeight, tgt(1, 1), bmi, DIB_RGB_COLORS) _
                Then
            
                ptr = VarPtr(tgt(1, 1))
                
            Else
                
                ' bei Fehler: tgt-bArray wieder auf usrprüngliche Dimension setzen
                ReDim tgt(1 To UBound(src, 1), 1 To UBound(src, 2))
                If eMD Then MsgBox "Bilddaten konnten nicht gelesen werden"
            End If
            
            If hDC Then ReleaseDC 0, hDC
        End With
    End If
    
    If ptr Then
        bmp.bmBitsPixel = 32
        bmp.bmWidthBytes = bmp.bmWidth * 4
        tmp = bmp.bmWidthBytes * bmp.bmHeight
        
        'src-bArray dimensionieren und mit Bilddaten füllen
        ReDim src(1 To bmp.bmWidthBytes, 1 To bmp.bmHeight)
        CopyMemory src(1, 1), ByVal ptr, tmp
        
        'asmBmpPara-Struktur setzen
        abp.src = bmp
        abp.src.bmBits = VarPtr(src(1, 1))
        
        abp.tgt = bmp
        abp.tgt.bmBits = ptr
        
        ReadData = True
    End If
End Function

Function WriteData(pbx As PictureBox, bmp As BITMAP, Optional force As Boolean _
    = False) As Boolean

    
    'Neues Picture-Objekt
    Dim pic         As IPicture
    
    'infos über das zu überschreibende Bild
    Dim tmp         As BITMAP
    
    'erw. infos über das Bild
    Dim bmi         As BITMAPINFO
    
    'info zum Erstellen eines neuen Pictures
    Dim dsc         As PictDesc
    
    'temporär benutzter Gerätekontext
    Dim hDC         As Long
    
    'Zeiger auf die binären Bilddaten
    Dim ptr         As Long
    Dim flg         As Long
    
    'clsid des IPicture-Objektes
    Dim iid(15)     As Byte
    
    flg = pbx.Picture.Handle And (force = False)
    If flg Then flg = GetObject(flg, Len(tmp), tmp)
    
    If bmp.bmBits = tmp.bmBits Then
        
        'tgt weist direkt auf den Bildobjekt-Speicher => nothing to do
        pbx.Refresh
        WriteData = True
        
    ElseIf flg > 0 And tmp.bmBits <> 0 And bmp.bmWidth = tmp.bmWidth And bmp.bmHeight _
        = tmp.bmHeight And bmp.bmBitsPixel = tmp.bmBitsPixel Then
    
        
        ' wenn das Ziel dasselbe Datenformat aufweist, einfach kopieren
        CopyMemory ByVal tmp.bmBits, ByVal bmp.bmBits, bmp.bmWidthBytes * bmp.bmHeight
        pbx.Refresh
        WriteData = True
        
    Else
        
        ' sonst 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 = 32
            .biHeight = bmp.bmHeight
            .biWidth = bmp.bmWidth
            .biPlanes = 1
            .biSizeImage = bmp.bmWidthBytes * bmp.bmHeight
        End With
        
        ' 1. Gerätekontext
        hDC = GetDC(0)
        
        ' 2. DIB-Section
        If hDC Then dsc.hImage = CreateDIBSection(hDC, bmi, DIB_RGB_COLORS, ptr, 0, _
            0)
        
        If hDC = 0 Then
            MsgBox "Gerätekontext konnte nicht erzeugt werden"
            
        ElseIf dsc.hImage = 0 Or ptr = 0 Then
            MsgBox "Bildkopie konnte nicht erstellt werden"
            
        Else
            CopyMemory ByVal ptr, ByVal bmp.bmBits, bmp.bmWidthBytes * bmp.bmHeight
            
            If CLSIDFromString(StrPtr(IID_IPicture), VarPtr(iid(0))) <> S_OK Then
                MsgBox "OLE Fehler"
                
                ' 3. IPicture-Objekt
            ElseIf CreatePic(dsc, VarPtr(iid(0)), True, pic) <> S_OK Then
                MsgBox "OLE picture creation error"
                
            Else
                
                ' ... und das Ergebnis auf die PictureBox setzen
                Set pbx.Picture = Nothing
                Set pbx.Picture = pic
                dsc.hImage = 0
                WriteData = True
            End If
        End If
        
        If hDC Then ReleaseDC 0, hDC
        If dsc.hImage Then DeleteObject dsc.hImage
    End If
End Function
'------- Ende Modul "asm_001ROU" alias asm_001ROU.bas -------
'------------ Ende Projektdatei prjChangeHSL.vbp ------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

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.