Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0793: Bilder mittels mehrerer StretchBlt API Aufrufe verzerren

VB 5/6-Tipp 0793: Bilder mittels mehrerer StretchBlt API Aufrufe verzerren

 von Danielo

Schwierigkeitsgrad:

Verwendete API-Aufrufe: SetBrushOrgEx, SetStretchBltMode, StretchBlt

Download: Download des Beispielprojektes [55,15 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 "picDest"
' Steuerelement: Bildfeld-Steuerelement "picSource"
' Steuerelement: Timersteuerelement "Timer1"
Option Explicit

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 Declare Function SetStretchBltMode Lib "gdi32" _
        (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
    
Private Declare Function SetBrushOrgEx Lib "gdi32.dll" ( _
                 ByVal hdc As Long, _
                 ByVal nXOrg As Long, _
                 ByVal nYOrg As Long, _
                 lppt As Any) As Long
                 
Private Const SRCCOPY = &HCC0020
Private Const DELETESCANS = 3
Private Const HALFTONE = 4

Private Const pi As Double = 3.141592654

Private xTable() As Double
Private yTable() As Double
Private xStep As Long
Private yStep As Long

Private Sub Form_Load()
    picSource.ScaleMode = vbPixels
    picDest.ScaleMode = vbPixels
    picDest.AutoRedraw = True
End Sub


Private Sub Timer1_Timer()
    Static msCountdown As Long
    Static ixTable As Long, iyTable As Long
    
    If msCountdown = 0 Then
        msCountdown = 10000
        SetNewTable
        ixTable = 0: iyTable = 0
    End If
    msCountdown = msCountdown - 50
    
    picDest.Cls
    Stretch picSource, picDest, ixTable, xTable, iyTable, yTable

    ixTable = ixTable + xStep
    If ixTable > UBound(xTable) Then ixTable = ixTable - UBound(xTable)

    iyTable = iyTable + yStep
    If iyTable > UBound(yTable) Then iyTable = iyTable - UBound(yTable)
End Sub


Private Sub SetNewTable()
    Static cCalls As Long
    Dim i As Long, j As Long
    Dim yStart As Double, yEnd As Double
    Dim Angle As Double
    
    Select Case cCalls
    Case 0
        ReDim xTable(127)
        ReDim yTable(127)
        For i = 0 To UBound(xTable)
            xTable(i) = Sin(pi * i / 64) + 1.5
        Next
        For i = 0 To UBound(yTable)
            yTable(i) = Sin(pi * i / 64) + 1.5
        Next
        xStep = 1: yStep = 1
    Case 1
        ReDim xTable(127)
        ReDim yTable(127)
        For i = 0 To UBound(xTable)
            xTable(i) = Sin(pi * i / 64) + 1.5
        Next
        For i = 0 To UBound(yTable)
            yTable(i) = Cos(pi * i / 64) + 1.5
        Next
        xStep = 1: yStep = 1
    Case 2
        ReDim xTable(127)
        ReDim yTable(128 * 5 - 1)
        For i = 0 To UBound(xTable)
            xTable(i) = Sin(pi * i / 64) + 1.5
        Next
        For i = 0 To UBound(yTable)
            yTable(i) = (Sin(pi * i / 64) + Sin(pi * i / 80)) + 1.5
        Next
        xStep = 1: yStep = 3
    Case 3
        ReDim xTable(128 * 128 - 1)
        ReDim yTable(128 * 128 - 1)

        For i = 0 To 127
            yStart = Sin(pi * i / 256)
            yEnd = 1
            For j = 0 To 127
                xTable(i * 128 + j) = Sin(pi * i / 256)
                yTable(i * 128 + j) = yStart + (yEnd - yStart) / 128 * j
            Next
        Next
        xStep = 128: yStep = 128
        cCalls = -1
    End Select
    
    cCalls = cCalls + 1
End Sub

Private Sub Stretch(picSource As PictureBox, picDest As PictureBox, ByVal ixTable As Long, xTable() As Double, ByVal iyTable As Long, yTable() As Double)
    Dim x As Long, i As Long
    Dim xWidth As Double
    Dim xShift As Long, yShift As Long   'zur anpassung an picDest Größe
    Dim xDest As Long, xSource As Long
    Dim WidthDest As Double, WidthSource As Long
    
    'alle x Faktoren summieren um die Breite des fertigen Bildes zu kennen
    x = ixTable
    For i = 0 To 128
        xWidth = xWidth + xTable(x)
        x = x + 1
        If x > UBound(xTable) Then x = 0
    Next
    xShift = (picDest.ScaleWidth - (xWidth * 2)) / 2
    yShift = (picDest.ScaleHeight - picSource.ScaleHeight) / 2
    
    'SetStretchBltMode picDest.hdc, HALFTONE        'zu langsam :P
    'SetBrushOrgEx picDest.hdc, 0, 0, ByVal 0
    
    SetStretchBltMode picDest.hdc, DELETESCANS      'schneller :D
    
    xDest = xShift: xSource = 0
    For x = 0 To 256 Step 2
        WidthSource = WidthSource + 2
        WidthDest = WidthDest + xTable(ixTable) * 2
        If WidthDest > 1 Then
            
            StretchBlt picDest.hdc, xDest, yShift + (1 - yTable(iyTable)) / 2 * 256, _
                    WidthDest, yTable(iyTable) * 256, picSource.hdc, xSource, 0, WidthSource, 256, SRCCOPY
        
            xSource = xSource + WidthSource
            xDest = xDest + WidthDest
            WidthSource = 0
            WidthDest = WidthDest - CLng(WidthDest)
        End If
        
        ixTable = ixTable + 1
        If ixTable > UBound(xTable) Then ixTable = 0
        
        iyTable = iyTable + 1
        If iyTable > UBound(yTable) Then iyTable = 0
    Next
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------