Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0789: Geschwindigkeitseffekte durch MotionBlurring

VB 5/6-Tipp 0789: Geschwindigkeitseffekte durch MotionBlurring

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: AlphaBlend, BitBlt, TransparentBlt

Download: Download des Beispielprojektes [87,37 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 Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "picTmp2"
' Steuerelement: Bildfeld-Steuerelement "picTmp"
' Steuerelement: Bildfeld-Steuerelement "picObject"
' Steuerelement: Bildfeld-Steuerelement "picBackground"
' Steuerelement: Bildfeld-Steuerelement "picMask"
Option Explicit

Private PosX            As Long, PosY           As Long
Private DirectionX      As Long, DirectionY     As Long

Private mScaleHeight    As Long, mScaleWidth    As Long

Private Running         As Boolean

Private XCoords         As Collection
Private YCoords         As Collection

Private Sub Form_Load()
    Set XCoords = New Collection
    Set YCoords = New Collection
    
    DirectionX = 3
    DirectionY = 3
    
    PosX = 1
    PosY = 1
    
    mScaleHeight = picTmp.ScaleHeight
    mScaleWidth = picTmp.ScaleWidth
    
    Running = True
    
    Call Me.Show
        
    Call DoAnimation(25)
    
    Call Unload(Me)
    Set Form1 = Nothing
End Sub

' Animation beendens
Private Sub Form_Unload(Cancel As Integer)
    Running = False
End Sub


' Die Kernfunktion:
' Es wird ein Objekt auf einen bestimmten Ausschnitt eines Zielbildes geblendet
Public Function Copy(ByVal x As Long, y As Long, ByVal Opacity As Byte)
    Dim lngFunc As Long
    
    lngFunc = CLng(Opacity) * 65536 ' RShift für die simlierte BLENDFUNCTION-Struktur

    ' Zielausschnitt in picTmp
    Call BitBlt(picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picBackground.hdc, x, y, vbSrcCopy)
    
    ' Zielausschnitt in picTmp2
    Call BitBlt(picTmp2.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picBackground.hdc, x, y, vbSrcCopy)
   
    ' Von picObject in picTmp kopieren, wobei schwarze Pixel nicht gezeichnet werden
    Call TransparentBlt(picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picObject.hdc, 0&, 0&, picObject.ScaleWidth, picObject.ScaleWidth, 0&)
    
    ' Mit angegebener Opazität vo picTmp nach picTmp2 blenden
    Call AlphaBlend(picTmp2.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, lngFunc)
    
    ' Die Maske in picTmp kopieren
    Call BitBlt(picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picMask.hdc, 0&, 0&, vbSrcCopy)
    
    ' Inhalt von picTmp2 mit der Maske in picTmp auf picTmp kopieren, sodass nur das eigentliche Objekt übrig bleibt und der Rest schwarz wird
    Call BitBlt(picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, picTmp2.hdc, 0&, 0&, vbSrcAnd)
    
    ' picTmp auf den Zielausschnitt kopieren, wobei schwarze Pixel nicht gezeichnet werden
    Call TransparentBlt(picBackground.hdc, x, y, mScaleWidth, mScaleHeight, picTmp.hdc, 0&, 0&, mScaleWidth, mScaleHeight, 0&)
End Function

Private Sub DoAnimation(ByVal Length As Long)
    Dim i As Long
    
    Do
        PosX = PosX + DirectionX
        PosY = PosY + DirectionY
        
        If PosX > picBackground.ScaleWidth - picTmp.ScaleWidth Or PosX < 0 Then DirectionX = -DirectionX
        If PosY > picBackground.ScaleHeight - picTmp.ScaleHeight Or PosY < 0 Then DirectionY = -DirectionY
        
        Call XCoords.Add(PosX): Call YCoords.Add(PosY)
        
        Call picBackground.Cls
        
        ' Die transparenten Abbilder des Objektes zeichnen
        For i = 1 To XCoords.Count
            Call Copy(XCoords(i), YCoords(i), CByte(255 * (i / XCoords.Count) ^ 3))
        Next i
        
        If XCoords.Count > Length Then Call XCoords.Remove(1): Call YCoords.Remove(1)
           
        Call [DoEvents]
              
    Loop While Running
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---------- Anfang Modul "mdlAPI" alias mdlAPI.bas ----------
Option Explicit

' Apideklarationen
Public Declare Function TransparentBlt Lib "msimg32.dll" (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 crTransparent As Long) As Boolean

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long

Public Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long

'----------- Ende Modul "mdlAPI" alias mdlAPI.bas -----------
'-------------- Ende Projektdatei Projekt1.vbp --------------