Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Oft reicht die Geschwindigkeit und Qualität von der API StretchBlt nicht aus, um Grafiken mit hoher Qualität auf dem Bildschirm skaliert darzustellen. Dann muss man sich entweder mit eigenen(meist langsamen) Algorithmen behelfen oder DirectX verwenden! Bei diesem Tipp wird ein Bild(250x250) komplett auf der Form gestreckt dargestellt. Und das mit verhältnismäßig wenig Aufwand.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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 --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

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 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.

Kommentar von Pixelkiller am 09.08.2004 um 23:24

wie kann ich die Blt-Funktion optionaler bauen ...
z.b ich nehme anstatt des Filenames eine andere Picturebox

Public Function LoadImageStretch(Filename As String, Height As Long, _
Width As Long, DDraw As DirectDraw7) As DirectDrawSurface7

ändern wir in

Public Function LoadImageStretch(Filename As Picture, Height As Long, _
Width As Long, DDraw As DirectDraw7) As DirectDrawSurface7

dann hätte ich doch die Möglichkeit die Blt-Funktion so umzubauen das ich z.B angeben kann ab wann er (X,Y) das Bild in die andere PictureBox übernehmen soll...
oder wie weit er das Bild in die andere PictureBox übernehmen soll (height,width)...

Für Tips dazu wäre ich sehr dankbar

Kommentar von Johannes Roth am 09.04.2004 um 18:11

kleiner Tipp am Rande:
ein vollständiges Archiv mit allem was benötigt wird und korrekten Einstellungen hilft oft weiter...