CreateDIBSection-Funktion Diese Funktion erstellt ein DIB-Bitmap (geräteunabhängig), in dem man direkt auf die Farbwerte im Speicher zugreifen kann.
Betriebssystem:  Win95, Win98, WinNT 3.1, Win2000, WinME	Views:  12.746

Deklaration:

Declare Function CreateDIBSection Lib "gdi32" ( _
  ByVal hdc As Long, _
   pBitmapInfo As BITMAPINFO, _
  ByVal un As Long, _
  lplpVoid As Long, _
  ByVal handle  As Long, _
  ByVal dw As Long) As Long

Beschreibung:
Diese Funktion erstellt ein DIB-Bitmap (geräteunabhängig), in dem man direkt auf die Farbwerte im Speicher zugreifen kann.

Parameter:

hdc	Erwartet das Handle des Gerätes, auf dem das Bitmap erstellt werden soll.
pBitmapInfo	Erwartet eine gefüllte BITMAPINFO-Struktur, die das zu erstellende Bitmap beschreibt.
un	Erwartet eine Konstante die beschreibt, ob die Farbtabelle der BITMAPINFO-Struktur eine 16-Bit Farbpalette oder eine RGB-Farbtabelle ist.
lplpVoid	Erwartet eineLong-Variable, die mit dem Pointer des Speicherbereiches gefüllt wird, in dem die Daten der RGB-Farbwerte abgelegt sind.
handle	Erwartet das Handle eines Filemapping-Objektes das benutzt wird, um die Bitmapdaten zuspeichern. Alternativ kann hier auch der Wert "0" übergeben werden, wenn das System dies selbständig machen soll.
dw	Wurde bei "Handle" ein Filemapping-Objekt übergeben, so wird hier der Offset erwartet, an dem begonnen werden soll die Daten abzulegen.

un Konstanten:

Const DIB_RGB_COLORS = 0
' RGB-Farb-Tabelle
 
Const DIB_PAL_COLORS = 1
' Farbpaletten-Einträge

Rückgabewert:
Ist die Funktion erfolgreich, so wird das Handle des erstellten DIB-Bitmaps zurückgegeben, andernfalls derWert "0". Unter Windows NT, 2000 und XP können Sie die GetLastError-Funktion für erweiterte Fehlerinformationen aufrufen.

Beispiel:

Private Declare Function GetDIBits Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hbmp As Long, _
  ByVal uStartScan As Long, _
  ByVal cScanLines As Long, _
  lpvBits  As Any, _
  lpbm As BITMAPINFO, _
  ByVal fuColorUse As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hbmp As Long, _
  ByVal nStartScan As Long, _
  ByVal cScanLines As Long, _
  lpvBits  As Any, _
  lpbm As BITMAPINFO, _
  ByVal fuColorUse As Long) As Long
Private Declare Function GetObject Lib "gdi32" _
  Alias "GetObjectA" ( _
  ByVal hObject As Long, _
  ByVal nCount As Long, _
  lpObject As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
  ByVal hdc As Long)  As Long
Private Declare Function CreateDIBSection Lib "gdi32" ( _
  ByVal hdc As Long, _
   pBitmapInfo As BITMAPINFO, _
  ByVal un As Long, _
  ByVal lplpVoid As Long, _
  ByVal handle As Long, _
  ByVal dw As Long) As Long
Private Declare Function LoadImage Lib "user32" _
  Alias "LoadImageA" ( _
  ByVal hInst As Long, _
  ByVal lpsz As String, _
  ByVal dwImageType As Long, _
  ByVal dwDesiredWidth As Long, _
  ByVal dwDesiredHeight As Long, _
  ByVal dwFlags As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
  ByVal hObject As Long)  As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" ( _
  ByVal hDcDest As Long, _
  ByVal xDest As Long, _
  ByVal yDest As Long, _
  ByVal WidthDest As Long, _
   ByVal HeightDest As Long, _
  ByVal hDcSrc As Long, _
  ByVal xSrc As Long, _
  ByVal ySrc As Long, _
  ByVal WidthSrc As Long, _
  ByVal HeightSrc As Long, _
  ByVal Blendfunc As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal x  As Long, _
  ByVal y As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long, _
   ByVal hSrcDC As Long, _
  ByVal xSrc As Long, _
  ByVal ySrc As Long, _
  ByVal nSrcWidth As Long, _
  ByVal nSrcHeight As Long, _
  ByVal dwRop As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" _
  Alias "RtlMoveMemory"  ( _
  Destination As Any, _
  Source As Any, _
  ByVal Length As Long)
 
Private Type BLENDFUNCTION
  BlendOp As Byte
  BlendFlags As Byte
  SourceConstantAlpha As Byte
  AlphaFormat As Byte
End Type
 
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
 
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
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
 
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
 
' BITMAPINFOHEADER biCompression-Konstanten
Private Const BI_RGB = 0& ' Das Bitmap ist nicht komprimiert
Private Const BI_RLE8 = 1& ' Das Bitmap ist komprimiert (Für 8-Bit Bitmaps)
Private Const BI_RLE4 = 2& ' Das Bitmap ist komprimiert (Für 4-Bit Bitmaps)
Private Const BI_BITFIELDS = 3& ' Das Bitmap ist nicht komprimiert. Die Farbtabelle enthält 
' eine Farbmaske (für 16-Bit/32-Bit Bitmaps)
 
' BLENDFUNCTION AlphaFormat-Konstante
Private Const AC_SRC_ALPHA = &H1
 
' BLENDFUNCTION BlendOp-Konstante
Private Const AC_SRC_OVER = &H0
 
' Get- / SetDiBits fuColorUse-Konstanten
Private Const DIB_RGB_COLORS = 0 ' RGB-Farb-Tabelle
Private Const DIB_PAL_COLORS = 1 ' Farbpaletten-Einträge
 
' eine der StretchBlt dwRop-Konstanten
Private Const SRCCOPY = &HCC0020
 
' eine der LoadImage dwImageType-Konstanten
Private Const IMAGE_BITMAP = 0
 
' eine der LoadImage dwFlags-Konstanten
Private Const LR_LOADFROMFILE = &H10
 
Dim hSprite As Long, pBF As Long

' Erstellen eines Alpha-Bitmaps anhand einer Maske
Private Function Add_AlphaMask(ByVal hDcDest As Long, ByVal SrcFile As _
String, ByVal MaskFile As String) As Long
  Dim hSrc As Long, hMask As Long
  Dim DibSrc As Long, DibMask As Long
  Dim hDcSrc As Long, hDcMask As Long
  Dim SrcSize As BITMAP, MaskSize As BITMAP
  Dim SrcBits() As RGBQUAD, MaskBits() As RGBQUAD
  Dim BMI As BITMAPINFO, BitmapSize As Long
 
  ' Bitmaps laden
  hSrc = LoadImage(App.hInstance, SrcFile, IMAGE_BITMAP, 0&, 0&, LR_LOADFROMFILE) 
  hMask = LoadImage(App.hInstance, App.Path & "\Mask.bmp", IMAGE_BITMAP,  _
  0&, 0&, LR_LOADFROMFILE)
 
  ' Bitmaps miteinander vergleichen
  Call GetObject(hSrc, Len(SrcSize), SrcSize)
  Call GetObject(hMask, Len(MaskSize), MaskSize)
  If (SrcSize.bmHeight << MaskSize.bmHeight) Or (SrcSize.bmWidth <<  _
  MaskSize.bmWidth) Then
    Call DeleteObject(hSrc)
    Call DeleteObject(hMask)
    Exit Function
  End If
 
  ' Kompatible Devicekontexte erstellen und Quellen zuweisen
  hDcSrc = CreateCompatibleDC(hDcDest)
  hDcMask = CreateCompatibleDC(hDcDest)
 
  ' DIB-Bitmaps erstellen (geräteunabhängige Bitmaps)
  With BMI.bmiHeader
    .biSize = Len(BMI.bmiHeader)
    .biWidth = SrcSize.bmWidth
    .biHeight = SrcSize.bmHeight
    .biPlanes = 1
    .biBitCount = 32  ' (Alpha / Rot / Grün / Blau)
    .biCompression = BI_RGB
    .biSizeImage = SrcSize.bmWidth * SrcSize.bmHeight * 4
    BitmapSize = .biSizeImage
  End With
  DibSrc = CreateDIBSection(hDcSrc, BMI, DIB_RGB_COLORS, 0&, 0&, 0&)
  DibMask = CreateDIBSection(hDcMask, BMI, DIB_RGB_COLORS, 0&, 0&, 0&)
 
  ' Bitmaps den Devicekontexten zuweisen
  SelectObject hDcSrc, hSrc
  SelectObject hDcMask, hMask
 
  ' Farben der Bitmaps ermitteln
  ReDim SrcBits(BitmapSize / 4)
  ReDim MaskBits(BitmapSize / 4)
  GetDIBits hDcSrc, hSrc, 0, SrcSize.bmHeight, SrcBits(0), BMI, DIB_RGB_COLORS 
  GetDIBits hDcMask, hMask, 0, SrcSize.bmHeight, MaskBits(0), BMI, DIB_RGB_COLORS 
 
  ' Alphawert (Transparenz) für jeden Pixel anhand der Maske bestimmen
  For i = 0 To BitmapSize / 4
    With MaskBits(i)
      SrcBits(i).rgbReserved = CInt(((.rgbRed) + CInt(.rgbGreen) +  _
      CInt(.rgbBlue)) / 3)
    End With
  Next i
 
  ' Modifizierte Farben (Alpha) zuweisen
  SetDIBits hDcSrc, hSrc, 0, SrcSize.bmHeight, SrcBits(0), BMI, DIB_RGB_COLORS 
 
  ' Nicht mehr benötigte Ressourcen entfernen
  Call DeleteObject(hMask)
  Call DeleteObject(hSrc)
  Call DeleteObject(DibMask)
  Call DeleteObject(DibSrc)
  Call DeleteObject(hDcMask)
 
  ' Handle zu dem modifizierten Bitmap zurückgeben
  Add_AlphaMask = hDcSrc
End Function

' Bitmap laden und BLENDFUNCTION-Struktur erstellen
Private Sub Form_Load()
  Dim BF As BLENDFUNCTION
 
  Picture1.AutoRedraw = True
  Picture1.ScaleMode = vbPixels
  Me.AutoRedraw = True
  Me.ScaleMode = vbPixels
 
  ' 2 Bitmaps (Bitmap & Alphamaske) miteinander kombinieren
  hSprite = Add_AlphaMask(Me.hdc, App.Path & "\Fill.bmp", App.Path & "\Mask.bmp") 
 
  ' Pointer zu einer BLENDFUNCTION-Struktur erstellen
  With BF
    .BlendOp = AC_SRC_OVER
    .BlendFlags = 0
    .SourceConstantAlpha = &HFF
    .AlphaFormat = AC_SRC_ALPHA
  End With
  MoveMemory pBF, BF, Len(BF)
End Sub

' Bitmap entladen
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Call DeleteDC(hSprite)
End Sub

' Bitmaps (Hintergrund & Sprite) anzeigen
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As _
Single, y As Single)
  Dim Zoom As Long
 
  ' Zoomfaktor des Sprit bestimmen
  Zoom = Me.ScaleWidth / 5 + 2
 
  ' Erst Hintergrund und dann das Sprite zeichnen
  Call StretchBlt(Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight,  _
  Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, SRCCOPY)
  Call AlphaBlend(Me.hdc, x - (Zoom + 2) / 2, y - Zoom / 2, Zoom + 2,  _
  Zoom, hSprite, 0, 0, 214, 216, pBF)
 
  ' Fensterinhalt neu zeichnen
  Me.Refresh
End Sub