Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Damit eine Bitmap als tranparent in eine andere eingebunden werden kann, muß eine sogenante 'Transparenzfarbe' ausgewählt werden. Das ermöglicht dann das Erstellen einer Monochrom- und einer invertierten Monochrom-Maske. Aus letzter wird wiederum durch Verschmelzung mit dem Orginalbils eine Maske mit schwarzem Hintergrund. Wie es geht, wir hier gezeigt.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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 --------------

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.

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.

Kommentar von Jürgen Fienau am 02.12.2007 um 00:46

Bei Bilder ab ca. 4 Mill. Pixel kommt Err-Fehler 6 (Ungültiges Hanle). Der Fehler tritt bei Call BitBlt(Mask1.hdc, 0, 0, W, H, hDCMask1, 0, 0, vbSrcCopy) auf. Was bedeutet es und wie kann man diesen Fehler beheben.
Danke im Voraus!
Jürgen Fienau

Kommentar von erik am 18.02.2002 um 09:19

Gibt es auch eine Möglichkeit, das nur die Farben geändert werden bis ein anderes Pixel kommt? Bei dem Beispiel wird auch innerhalb der Sektflasche ein Teil maskiert. Ich möchte nur den Rand haben