VB 5/6-Tipp 0114: Bitmap transparent in eine andere Grafik einbinden

von ActiveVB

Beschreibung

Die in den letzen beiden Tips erstellten und zur Animation genutzten Masken, können auch, wie hier geschehen, in einem Rutsch ohne das lästige Zwischspeichern in PictureBoxen generiert werden. Dazu werden hinter den Kulissen von Windows 'unsichtbare' Bitmaps erstellt in denen im wesentlichen die selben Operationen wie in Tip 112, 113 ablaufen. Zur Animation ist die hier vorgestellte Version nicht unbedingt geeignet, da hier (ist aber noch nicht geschehen) auch minimale Flackereffekte auftauchen könnten. zur Behebung dieses Mankos kann das Programm aber der jeweiligen Animation gut angepaßt werden.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

BitBlt, CreateBitmap, CreateCompatibleBitmap, CreateCompatibleDC, DeleteDC, DeleteObject, SelectObject, SetBkColor

Download:

Download des Beispielprojektes [19,78 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 "Picture3"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' 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 CreateCompatibleBitmap Lib "gdi32" (ByVal _
        hdc As Long, ByVal nWidth As Long, ByVal nHeight 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 Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Dim R As RECT
Dim PMove As Boolean

Private Sub Form_Load()
  Picture1.ScaleMode = vbPixels
  Picture1.AutoRedraw = True
  Picture2.ScaleMode = vbPixels
  
  With R
   .Left = 0
   .Top = 0
   .Right = Picture2.ScaleWidth
   .Bottom = Picture2.ScaleHeight
  End With
  
  Picture3.Picture = Picture1.Picture
End Sub

Private Sub Picture1_Click()
  PMove = IIf(PMove, False, True)
End Sub

Private Sub Picture1_MouseMove(Button As Integer, _
                               Shift As Integer, _
                               X As Single, Y As Single)
                               
  If PMove Then Call MovePicTo(X, Y)
End Sub

Private Sub TranspPic(OutDstDC&, DstDC&, SrcDC&, SrcRect _
                      As RECT, ByVal DstX&, ByVal DstY&, _
                      TransColor&)
 
  Dim Result&, W&, H&
  Dim MonoMaskDC&, hMonoMask&, MonoInvDC&, hMonoInv&
  Dim ResultDstDC&, hResultDst&, ResultSrcDC&, hResultSrc&
  Dim hPrevMask&, hPrevInv&, hPrevSrc&, hPrevDst&
    
    W = SrcRect.Right - SrcRect.Left
    H = SrcRect.Bottom - SrcRect.Top
     
    'Generieren einer Monochromen & einer inversen Maske
    MonoMaskDC = CreateCompatibleDC(DstDC)
    MonoInvDC = CreateCompatibleDC(DstDC)
    hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
    hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
    hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
    hPrevInv = SelectObject(MonoInvDC, hMonoInv)
     
    'Puffer erstellen
    ResultDstDC = CreateCompatibleDC(DstDC)
    ResultSrcDC = CreateCompatibleDC(DstDC)
    hResultDst = CreateCompatibleBitmap(DstDC, W, H)
    hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
    hPrevDst = SelectObject(ResultDstDC, hResultDst)
    hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
     
    'Sourcebild in die monochrome Maske kopieren
    Dim OldBC As Long
    OldBC = SetBkColor(SrcDC, TransColor)
    Result = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, _
                  SrcRect.Left, SrcRect.Top, vbSrcCopy)
    TransColor = SetBkColor(SrcDC, OldBC)
     
    'Inverse Maske erstellen
    Result = BitBlt(MonoInvDC, 0, 0, W, H, _
                  MonoMaskDC, 0, 0, vbNotSrcCopy)
     
    'Hintergrund des Zielbildes auslesen
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  DstDC, DstX, DstY, vbSrcCopy)
     
    'AND mit der Maske
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  MonoMaskDC, 0, 0, vbSrcAnd)
     
    'Überlappung des Sourcebildes mit dem Zielbild auslesen
    Result = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, _
                  SrcRect.Left, SrcRect.Top, vbSrcCopy)
     
    'AND mit der invertierten, monochromen Maske
    Result = BitBlt(ResultSrcDC, 0, 0, W, H, _
                  MonoInvDC, 0, 0, vbSrcAnd)
     
    'XOR mit beiden
    Result = BitBlt(ResultDstDC, 0, 0, W, H, _
                  ResultSrcDC, 0, 0, vbSrcInvert)
     
    'Ergebnis in das Zielbild kopieren
    Result = BitBlt(OutDstDC, DstX, DstY, W, H, _
                  ResultDstDC, 0, 0, vbSrcCopy)
     
    'Erstellte Objekte & DCs wieder freigeben
    hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
    DeleteObject hMonoMask
    DeleteDC MonoMaskDC
    
    hMonoInv = SelectObject(MonoInvDC, hPrevInv)
    DeleteObject hMonoInv
    DeleteDC MonoInvDC
    
    hResultDst = SelectObject(ResultDstDC, hPrevDst)
    DeleteObject hResultDst
    DeleteDC ResultDstDC
    
    hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
    DeleteObject hResultSrc
    DeleteDC ResultSrcDC
End Sub

Private Sub MovePicTo(ByVal X&, ByVal Y&)
  X = X - R.Right / 2
  Y = Y - R.Bottom / 2
  Picture1.Picture = Picture3.Picture
  Call TranspPic(Picture1.hdc, Picture1.hdc, Picture2.hdc, _
                R, X, Y, vbWhite)
  Picture1.Refresh
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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 7 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 Daniel Pramel am 12.09.2006 um 17:38

Hi Tobias,

Dein Eintrag ist zwar schon länger her aber vielleicht hilft es Dir ja noch:

Setze Picture2.AutoRedraw auf True.
Dann ist es egal, ob die Picturebox verdeckt oder unsichtbar ist.

Darüberhinaus muss das Originalbild nicht wie im Beispiel vorher in Picture3 gesichert werden. Ein Cls() genügt.

Die Funktion MovePicTo() kann also ruhig so aussehen:

Private Sub MovePicTo(ByVal X&, ByVal Y&)
X = X - R.Right / 2
Y = Y - R.Bottom / 2
' ÄNDERUNG START
Picture1.Cls
' ÄNDERUNG ENDE
Call TranspPic(Picture1.hdc, Picture1.hdc, Picture2.hdc, _
R, X, Y, vbWhite)
Picture1.Refresh
End Sub

Der entsprechende Kopiervorgang im Form_Load() entfällt damit auch.

Gruß,
Daniel

Kommentar von Tobias Fischer am 25.02.2006 um 20:15

Mich würde sehr interessieren, warum nicht das korrekt Bild eingebunden wird, wenn das einzufügende nicht sichtbar, oder mit anderen Objekten überdeckt ist.
(Bei einem Bild, das sowieso irgendwo auf dem Bildschirm sichtbar sein muss, macht es nur sehr wenig Sinn, es überhaupt transparent in ein anderes einzubinden.)Mich würde sehr interessieren, warum das Bild nicht korrekt eingebunden wird, wenn das einzufügende nicht sichtbar, oder mit anderen Objekten überdeckt ist.
(Bei einem Bild, das sowieso irgendwo auf dem Bildschirm sichtbar sein muss, macht es nur sehr wenig Sinn, es überhaupt transparent in ein anderes einzubinden.)

Vielen Dank im Voraus

Mit freundlichen Grüßen: Tobias Fischer

Kommentar von Dark_Rain am 23.10.2004 um 18:27

Guten Tag,

Ist es möglich, wenn man auf das Picture1 klickt, dass dann nicht das alte kleine Bild verschoben wird sondern dass ein zweites kleines Bild erstellt wird. Das wäre richtig klasse!

MfG
Dark Rain

Kommentar von AnonymousProgrammer am 02.10.2004 um 18:54

Ein lustiger Effekt zum Thema transparentes Einbinden:
Benötigt werden 3 Pictureboxes(Picture1 und Picture2), in die 2 unterschiedliche Bilder geladen werden,die dritte ist leer, und
ein Button(Command1).
Die Image Boxen haben "AutRedraw = True" und
"Scalemode = 3 - Pixel".

On Error Resume Next
Dim col1,col2,col3
For i = 1 To 300
For i = 1 To 300
'Farbwert an stelle (i/b) für Picture1 auslesen:
col1 = Picture1.Point(i, b)
'Farbwert an stelle (i/b) für Picutre2 auslesen:
col2 = Picture2.Point(i, b)
'Dann den Farbwert für die dritte Box ausrechnen,
'man kann verschiedenes mit den Werten anstellen:
'Subtrahieren col3 = col2 - col1
'Addieren col3 = col1 + col2
'Den durchschnitt ausrechen: col3 = (col1 + col2)/2
'col3 in die 3.Box einsetzen:
Picture3.PSet (i, b), X
Next i
Next b

Leider ist die so einfache Pset-Methode zu langsam zum Morphing.

Kommentar von Carsten Schacht am 29.07.2004 um 21:02

Hallo,
der o.g. code funktioniert sehr schön, aber.....

ist es auch moglich ein bitmap transperent zu machen,
ohne dass die bitmap irgendwo sichtbar sein muß?
am besten wäre eine einzige große Bitmap (z.B. weisser Hintergrund) und das anzuzeigende Objekt der Begierde liegt irgendwo darauf. Per übergabe der Koordinaten kann hier die Grafik genommen werden und angezeigt werden. Ich bin mir nicht 100% sicher aber bei meinem alten AMIGA war diese Funktion unter "Blitten" bekannt.

Danke im Vorraus

Carsten aus Berlin

Kommentar von Ingo am 14.07.2003 um 13:18

Hallo!

Kann ich das transparente Bild irgendwie in einem Bildformat speichern, das Transparenz unterstützt?

Danke u. Gruss
Ingo

Kommentar von eclere am 04.01.2002 um 18:00

hallo,
mich würd mal interessieren ob es auch möglich ist das bild mit dem neuen bitmap drüber zu speichern.
gruss eclere