Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0371: Überblendeffekte mit Bitmaps

VB 5/6-Tipp 0371: Überblendeffekte mit Bitmaps

 von Dirk Lietzow

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, GetTickCount, StretchBlt

Download: Download des Beispielprojektes [63,7 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: Schaltfläche "Command5"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "SBild"
' Steuerelement: Bildfeld-Steuerelement "Picture1"


'Autor: Dirk Lietzow
'E-Mail: tipps@activevb.de

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private 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

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 Const SRCCOPY As Long = &HCC0020

Private tim As Long

Private Sub Command1_Click()
    'Streifen
    Picture1.Picture = LoadPicture(App.Path & _
        IIf(Right(App.Path, 1) = "\", "", "\") & "Pic1.JPG")
        
    Call Change(SBild, 1, 20, 40)
End Sub

Private Sub Command2_Click()
    'Blöcke
    Picture1.Picture = LoadPicture(App.Path & _
        IIf(Right(App.Path, 1) = "\", "", "\") & "Pic2.JPG")
        
    Call Change(SBild, 2, 15, 5)
End Sub

Private Sub Command3_Click()
    'Scrollen
    Picture1.Picture = LoadPicture(App.Path & _
        IIf(Right(App.Path, 1) = "\", "", "\") & "Pic3.JPG")
    Call Change(SBild, 3, 20, 50)
End Sub

Private Sub Command4_Click()
    'Zoom
    Picture1.Picture = LoadPicture(App.Path & _
        IIf(Right(App.Path, 1) = "\", "", "\") & "Pic4.JPG")
    Call Change(SBild, 4, 30, 800)
End Sub

Private Sub Command5_Click()
    'Kopieren
    Picture1.Picture = LoadPicture(App.Path & _
        IIf(Right(App.Path, 1) = "\", "", "\") & "Pic5.JPG")
    Call Change(SBild, 0, 0, 0)
End Sub

Private Sub WaitTick(time_to_wait As Long)
    Dim ctim As Long
    Dim u As Integer
    
    Do
        u = DoEvents 'mach die anderen Dinge .....
        ctim = GetTickCount&()
    Loop Until ctim > time_to_wait + tim
End Sub

Public Sub Change(PicBox As PictureBox, effect As Integer, _
                  stepsize As Integer, steptime As Long)
    
    Dim u As Integer
    Dim pixelwidth As Long
    Dim pixelheight As Long
    Dim a As Integer, b As Integer, i As Integer
    Dim blks() As Integer
    Dim u1 As Integer, u2 As Integer
    Dim b0 As Integer, b1 As Integer
    Dim chk As Integer
    Dim chkx As Integer, chky As Integer
    
    pixelwidth = Picture1.ScaleWidth
    pixelheight = Picture1.ScaleHeight
    
    With PicBox
        Select Case effect
            Case 0  'einfaches blitten, kein Effekt
                u = BitBlt(.hdc, 0, 0, pixelwidth, pixelheight, _
                Picture1.hdc, 0, 0, SRCCOPY)
                 
            Case 1 'vertikale Streifen, erst nach oben, dann nach unten
                chk = (pixelheight \ stepsize)
                
                For a = 0 To stepsize Step 2
                    tim = GetTickCount()
                    u = BitBlt(.hdc, 0, chk * a, pixelwidth, _
                               chk, Picture1.hdc, 0, chk * a, _
                               SRCCOPY)
                  
                    u = DoEvents()
                    Call WaitTick(steptime)
                Next a
                 
                For a = stepsize - 1 To 1 Step -2
                    tim = GetTickCount()
                    u = BitBlt(.hdc, 0, chk * a, pixelwidth, chk, _
                               Picture1.hdc, 0, chk * a, SRCCOPY)
                               
                    u = DoEvents()
                    Call WaitTick(steptime)
                Next a
                 
            Case 2 'Zufallsblöcke
                ReDim blks(1, stepsize ^ 2)
                For a = 0 To stepsize - 1
                    For b = 0 To stepsize - 1
                        blks(0, a + b * stepsize) = a
                        blks(1, a + b * stepsize) = b
                    Next b
                Next a
                 
                'mixen
                For a = 1 To stepsize * 10
                    u1 = Int(Rnd(1) * (stepsize ^ 2))
                    u2 = Int(Rnd(1) * (stepsize ^ 2))
                    b0 = blks(0, u1): b1 = blks(1, u1)
                    blks(0, u1) = blks(0, u2)
                    blks(1, u1) = blks(1, u2)
                    blks(0, u2) = b0
                    blks(1, u2) = b1
                Next a
                
                chkx = (pixelwidth \ stepsize)
                chky = (pixelheight \ stepsize)
                 
                'Blöcke blitten
                For a = 0 To (stepsize ^ 2) - 1
                    tim = GetTickCount&()
                    u = BitBlt(.hdc, blks(0, a) * chkx, _
                               blks(1, a) * chky, chkx + 1, _
                               chky + 1, Picture1.hdc, blks(0, a) _
                               * chkx, blks(1, a) * chky, SRCCOPY)
                    
                    u = DoEvents()
                    Call WaitTick(steptime)
                Next a
                 
            Case 3 'Scrollen von rechts oder links
                Dim to1 As Integer
                Dim to2 As Integer
                Dim st As Integer
                
                chk = (pixelwidth \ stepsize)
                i = Int(Rnd(1) * 2) 'Zufällige Richtung
                 
                If i < 1 Then
                   st = 1: to1 = 0: to2 = stepsize
                Else
                   to1 = stepsize
                   to2 = 0
                   st = -1
                End If
                 
                For a = to1 To to2 Step st
                    tim = GetTickCount()
                    u = BitBlt(.hdc, chk * a, 0, chk, _
                               pixelheight, Picture1.hdc, chk * a, _
                               0, SRCCOPY)
                    
                    u = DoEvents()
                    Call WaitTick(20)
                Next a
                 
            Case 4 'Zoomen
                chkx = pixelwidth / stepsize
                chky = pixelheight / stepsize
                
                For a = 1 To stepsize - 1
                    u = StretchBlt(.hdc, 0, 0, a * chkx, a * chky, _
                                   Picture1.hdc, 0, 0, pixelwidth, _
                                   pixelheight, SRCCOPY)
                    
                   Call WaitTick(20)
                Next a
                 
                'Richtig Positionieren
                u = BitBlt(.hdc, 0, 0, pixelwidth, pixelheight, _
                           Picture1.hdc, 0, 0, SRCCOPY)
        End Select
    End With
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.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.