Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0446: Mit DirectX ein Bild gestreckt auf eine Form blitten

VB 5/6-Tipp 0446: Mit DirectX ein Bild gestreckt auf eine Form blitten

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, CreateCompatibleDC, DeleteDC, SelectObject, StretchBlt

Download: Download des Beispielprojektes [3,47 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 -------------
' Es muss ein Verweis auf 'DirectX 7 for Visual Basic Type Library' gesetzt werden.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

Dim objDX As New DirectX7
Dim objDD As DirectDraw7
Dim objDDSurf As DirectDrawSurface7
Dim objDDPrimSurf As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2

Private Sub Blt()
    ' Schritt 4: Blit
    Dim r1 As RECT
    Dim r2 As RECT
    Dim ddrval As Long
    
    Call objDX.GetWindowRect(Picture1.hWnd, r1)
    r2.Bottom = ddsd2.lHeight
    r2.Right = ddsd2.lWidth
    ddrval = objDDPrimSurf.Blt(r1, objDDSurf, r2, DDBLT_WAIT)
End Sub

Private Sub Form_Load()
    Init
End Sub

Private Sub Form_Resize()
    Picture1.Width = Me.ScaleWidth
    Picture1.Height = Me.ScaleHeight
    Blt
End Sub

Private Sub Init()
    Set objDD = objDX.DirectDrawCreate("")
    Call objDD.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
    
    'Surface 1 erzeugen
    ddsd1.lFlags = DDSD_CAPS
    ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
    Set objDDPrimSurf = objDD.CreateSurface(ddsd1)
    
    ' Surface 2 erzeugen
    ddsd2.lFlags = DDSD_CAPS
    ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    Set objDDSurf = LoadImage(App.Path + "\Blitting to the Screen.gif", objDD)
End Sub

Private Sub Picture1_Paint()
    Blt
End Sub

'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--- Anfang Modul "JPEGtoSURFACE" alias JPEGtoSURFACE.bas ---

Option Explicit

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 CreateCompatibleDC Lib "gdi32" ( _
                        ByVal hdc As Long) As Long
                        
Public Declare Function DeleteDC Lib "gdi32" ( _
                        ByVal hdc As Long) As Long
                        
Public Declare Function SelectObject Lib "gdi32" ( _
                        ByVal hdc As Long, _
                        ByVal hObject As Long) As Long
                        
Public 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

'Ladet das JPEG bild in ein DD-Surface
Public Function LoadImage(Filename As String, DDraw As DirectDraw7) As DirectDrawSurface7
    Dim TPict As StdPicture
    Set TPict = LoadPicture(Filename)
    
    Dim SDesc As DDSURFACEDESC2
    
    'Surface eigenschaften festlegen
    SDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    SDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    SDesc.lHeight = CLng((TPict.Height * 0.001) * 567 / Screen.TwipsPerPixelY)
    SDesc.lWidth = CLng((TPict.Width * 0.001) * 567 / Screen.TwipsPerPixelX)
    
    If LCase(Right(Filename, 3)) = "bmp" Then
        Set LoadImage = DDraw.CreateSurfaceFromFile(Filename, SDesc)
    Else
        'Normales Surface mit obigen Eigenschaften erzeugen
        Set LoadImage = DDraw.CreateSurface(SDesc)
        
        'Den Device-Context abfragen
        Dim SDC As Long, TDC As Long
        SDC = LoadImage.GetDC
        TDC = CreateCompatibleDC(0)
        SelectObject TDC, TPict.Handle
        
        BitBlt SDC, 0, 0, SDesc.lWidth, SDesc.lHeight, TDC, 0, 0, vbSrcCopy
        
        LoadImage.ReleaseDC SDC
        DeleteDC TDC
    End If
    
    Set TPict = Nothing
End Function

'Das selbe nur, dass das Bild gedehnt wird
Public Function LoadImageStretch(Filename As String, Height As Long, Width As Long, _
    DDraw As DirectDraw7) As DirectDrawSurface7
    
    Dim TPict As New StdPicture
    Set TPict = LoadPicture(Filename)
    
    Dim SDesc As DDSURFACEDESC2
    
    SDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    SDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    SDesc.lHeight = Height
    SDesc.lWidth = Width
    
    If LCase(Right(Filename, 3)) = "bmp" Then
        Set LoadImageStretch = DDraw.CreateSurfaceFromFile(Filename, SDesc)
    Else
        Set LoadImageStretch = DDraw.CreateSurface(SDesc)
        
        Dim SDC As Long, TDC As Long
        SDC = LoadImageStretch.GetDC
        TDC = CreateCompatibleDC(0)
        SelectObject TDC, TPict.Handle
        
        StretchBlt SDC, 0, 0, Width, Height, TDC, 0, 0, CLng((TPict.Width * 0.001) * 567 / _
            Screen.TwipsPerPixelX), CLng((TPict.Height * 0.001) * 567 / Screen.TwipsPerPixelY), _
            vbSrcCopy
        
        LoadImageStretch.ReleaseDC SDC
        DeleteDC TDC
    End If
    
    Set TPict = Nothing
End Function

'---- Ende Modul "JPEGtoSURFACE" alias JPEGtoSURFACE.bas ----
'-------------- 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.