Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0112: Masken für transparente Bitmaps erstellen

VB 5/6-Tipp 0112: Masken für transparente Bitmaps erstellen

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, CreateBitmap, CreateCompatibleDC, DeleteDC, DeleteObject, SelectObject, SetBkColor

Download: Download des Beispielprojektes [7,75 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 Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "Picture4"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture3"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As _
        Long, ByVal XDest As Long, ByVal YDest As Long, ByVal _
        nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc _
        As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal _
        dwRop As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal _
        nWidth As Long, ByVal nHeight As Long, ByVal nPlanes _
        As Long, ByVal nBitCount As Long, lpBits As Any) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As _
        Long, ByVal crColor As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As _
        Long, ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc _
        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 Sub Form_Load()
  Picture1.ScaleMode = vbPixels
  Picture2.ScaleMode = vbPixels
  Picture3.ScaleMode = vbPixels
  Picture4.ScaleMode = vbPixels
  
  Picture2.AutoRedraw = True
  Picture3.AutoRedraw = True
  Picture4.AutoRedraw = True
End Sub

Private Sub Command1_Click()
    Call MonoMask(Picture1, vbWhite, Picture2, _
                  Picture3, Picture4)
    
    '### Bild2 -> Image
    Picture2.Refresh
    Picture2.AutoRedraw = True
    Picture2.AutoRedraw = False

    '### Bild3 -> Image
    Picture3.Refresh
    Picture3.AutoRedraw = True
    Picture3.AutoRedraw = False
    
    '### Bild4 -> Image
    Picture4.Refresh
    Picture4.AutoRedraw = True
    Picture4.AutoRedraw = False
End Sub

Private Sub MonoMask(Source As PictureBox, ByVal MaskColor&, _
                     Mask1 As PictureBox, ByVal Mask2 As _
                     PictureBox, ByVal Mask3 As PictureBox)
                     
  Dim hDCMask1&, hMask1&, hDCMask2&, hMask2&
  Dim hPrevMask1&, hPrevMask2&, W&, H&
    
    W = Source.Width
    H = Source.Height
    Mask1.Width = W
    Mask1.Height = H
    Mask2.Width = W
    Mask2.Height = H
    Mask3.Width = W
    Mask3.Height = H
    
    'Generieren zweier Bitmaps
    hDCMask1 = CreateCompatibleDC(Mask1.hdc)
    hDCMask2 = CreateCompatibleDC(Mask1.hdc)
    
    hMask1 = CreateBitmap(W, H, 1, 1, ByVal 0&)
    hMask2 = CreateBitmap(W, H, 1, 1, ByVal 0&)
    
    hPrevMask1 = SelectObject(hDCMask1, hMask1)
    hPrevMask2 = SelectObject(hDCMask2, hMask2)

    'Maskenfarbe des Originalbildes festlegen
    Call SetBkColor(Source.hdc, MaskColor)
    
    'Monochrome Maske des Originalbildes erstellen
    Call BitBlt(hDCMask1, 0, 0, W, H, Source.hdc, _
                0, 0, vbSrcCopy)
    
    'Erstellte monochrome Maske nach Picture4 kopieren
    Call BitBlt(Mask1.hdc, 0, 0, W, H, _
                hDCMask1, 0, 0, vbSrcCopy)
         
    'Inverse Maske der erstellen Maske generieren
    Call BitBlt(hDCMask2, 0, 0, W, H, _
                hDCMask1, 0, 0, vbNotSrcCopy)
    
    'Erstellte inverse Maske nach MaskInvers kopieren
    Call BitBlt(Mask2.hdc, 0, 0, W, H, _
                hDCMask2, 0, 0, vbSrcCopy)

    'Originalbildes in die Schlußmaske kopieren
    Call BitBlt(Mask3.hdc, 0, 0, W, H, Source.hdc, _
                0, 0, vbSrcCopy)
     
    'AND der Schlußmaske mit der invertierten Maske
    Call BitBlt(Mask3.hdc, 0, 0, W, H, _
                Mask2.hdc, 0, 0, vbSrcAnd)

    'Erstellte Objekte & DCs wieder freigeben
    Call DeleteObject(SelectObject(hDCMask1, hPrevMask1))
    Call DeleteObject(SelectObject(hDCMask2, hPrevMask2))
    Call DeleteDC(hDCMask1)
    Call DeleteDC(hDCMask2)
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

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