Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0727: Komplettes Bildschirmfoto einer Webseite erstellen

VB 5/6-Tipp 0727: Komplettes Bildschirmfoto einer Webseite erstellen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: FindWindowExA (FindWindowEx), FreeLibrary, GetSystemMetrics, LoadLibraryA (LoadLibrary), MoveWindow, OleDraw

Download: Download des Beispielprojektes [5,63 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 WebCapture.vbp ------------
' Die Komponente 'Microsoft Internet Controls (SHDOCVW.dll)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "cmdCapture"
' Steuerelement: Bildfeld-Steuerelement "picCapture"
' Steuerelement: Webbrowsercontrol "WebBrowser1"
' Steuerelement: Schaltfläche "cmdNavigate"
' Steuerelement: Textfeld "txtURL"
' Ein Teilcode satmmt von dieser Seite
' http://topic.csdn.net/t/20050807/16/4194178.html
Option Explicit

' Bei der Form auf der sich das Webbrowser-Control befindet, kann sogar die
' Eigenschaft Visible auf False gesetzt werden so das das
' Webbrowser-Control noch nicht mal sichtbar sein muss. Die Eigenschaft
' Visible des Webbrowser-Controls muss aber auf True stehen.

' Anstelle einer PictureBox kann auch ein eigener DC im Speicher verwendet
' werden. zB über CreateCompatibleBitmap, CreateCompatibleDC usw.

' Da hier der ScreenShot der Webseite als Bitmap gespeichert wird, können
' sehr große Dateien entstehen. Ein ScreenShot des Hauptforums auf ActiveVB
' zB. erzeugt bei einer festen Breite von 800 Pixel eine fast 20MB große
' Bitmap.

' ---=== Const ===---
Private Const S_OK As Long = &H0
Private Const SM_CXVSCROLL As Long = 2
Private Const SM_CYHSCROLL As Long = 3

' ---=== Enum ===---
Private Enum DVASPECT
    DVASPECT_CONTENT = 1
    DVASPECT_THUMBNAIL = 2
    DVASPECT_ICON = 4
    DVASPECT_DOCPRINT = 8
End Enum

' ---=== Typ ===---
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' ---=== KERNEL32 ===---
Private Declare Function LoadLibrary Lib "kernel32" _
                         Alias "LoadLibraryA" ( _
                         ByVal lpLibFileName As String) As Long
                         
Private Declare Function FreeLibrary Lib "kernel32" ( _
                         ByVal hLibModule As Long) As Long

' ---=== USER32 ===---
Private Declare Function GetSystemMetrics Lib "user32" ( _
                         ByVal nIndex As Long) As Long
                         
Private Declare Function FindWindowEx Lib "user32.dll" _
                         Alias "FindWindowExA" ( _
                         ByVal hWnd1 As Long, _
                         ByVal hWnd2 As Long, _
                         ByVal lpsz1 As String, _
                         ByVal lpsz2 As String) As Long
                         
Private Declare Function MoveWindow Lib "user32.dll" ( _
                         ByVal hwnd As Long, _
                         ByVal x As Long, _
                         ByVal y As Long, _
                         ByVal nWidth As Long, _
                         ByVal nHeight As Long, _
                         ByVal bRepaint As Long) As Long
                         
' ---=== OLE32 ===---
Private Declare Function OleDraw Lib "ole32.dll" ( _
                         ByVal pUnknown As Object, _
                         ByVal dwAspect As DVASPECT, _
                         ByVal hdcDraw As Long, _
                         ByRef lprcBounds As RECT) As Long
                         
Private m_hMod As Long
                         
' ------------------------------------------------------
' Funktion     : CaptureWeb
' Beschreibung : Kompletten ScreenShot von einer Webseite erstellen
' Übergabewert : PicPath = Pfad zum speichern des Bildes
'                minWidth = Mindestbreite für das Bild
'                minHeight = Mindesthöhe für das Bild
'                AutoSize = True = Automatische Ermittlung der
'                           Mindestbreite und Höhe für das Bild
'                           False = Mindestbreite bzw. Höhe für
'                           das Bild verwenden
' Rückgabewert : True = speichern des Bildes war erfolgreich
'                False = speichern des Bildes war nicht erfolgreich
' ------------------------------------------------------
Private Function CaptureWeb(ByVal PicPath As String, Optional ByVal minWidth As _
    Long = 800, Optional ByVal minHeight As Long = 600, Optional ByVal AutoSize _
    As Boolean = False) As Boolean
    
    Dim bolRet As Boolean
    Dim bolOffset As Boolean
    Dim bolScrollBars As Boolean
    Dim lngDocViewHwnd As Long
    Dim lngEmbeddingHwnd As Long
    Dim lngOrgWidth As Long
    Dim lngOrgHeight As Long
    Dim lngSiteHeight As Long
    Dim lngSiteWidth As Long
    Dim tRECT As RECT
    
    bolOffset = False
    bolScrollBars = False
    
    ' ist eine Webseite geladen
    If Not (WebBrowser1.Document Is Nothing) Then
    
        ' Fenster "Shell Embedding" finden
        lngEmbeddingHwnd = FindWindowEx(Me.hwnd, 0&, "Shell Embedding", _
            vbNullString)
            
        ' ist ein Handle auf das Fenster vorhanden
        If lngEmbeddingHwnd <> 0& Then
        
            ' Fenster "Shell DocObject View" finden
            lngDocViewHwnd = FindWindowEx(lngEmbeddingHwnd, 0&, "Shell " & _
                "DocObject View", vbNullString)
                
            ' ist ein Handle auf das Fenster vorhanden
            If lngDocViewHwnd <> 0& Then
            
                ' Original Höhe und Breite des Webbrowser-Controls in Pixel
                ' speichern
                lngOrgWidth = Me.ScaleX(WebBrowser1.Width, Me.ScaleMode, vbPixels)
                lngOrgHeight = Me.ScaleY(WebBrowser1.Height, Me.ScaleMode, vbPixels)
                    
                With tRECT
                
                    .Left = -1
                    .Top = -1
                    
                    If AutoSize Then
                    
                        ' auomatische Größe ermitteln
                        .Right = 0
                        .Bottom = 0
                        
                    Else
                    
                        ' wenn eine Mindesthöhe oder Breite verwendet
                        ' werden soll
                        .Right = minWidth + 4
                        .Bottom = minHeight + 4
                        
                    End If
                    
                End With
                
                ' das Fenster "Shell DocObject View" auf die festgelegte
                ' Größe aufziehen
                If MoveWindow(lngDocViewHwnd, 0, 0, tRECT.Right, tRECT.Bottom, _
                    0) <> 0 Then
                    
                    ' Höhe und Breite der Internetseite ermitteln
                    If WebBrowser1.Document.documentElement.clientWidth = 0 And _
                        WebBrowser1.Document.documentElement.clientHeight = 0 _
                        Then
                        
                        ' diese Seiten haben nur Scrollbalken, wenn die Größe des
                        ' Browserfensters zu klein für die Seite ist. Ansonsten nicht.

                        ' Scrollbalken entfernen
                        WebBrowser1.Document.body.Scroll = "no"
                        
                        ' merken das die Scrollbalken entfernt wurden
                        bolScrollBars = True
                        
                        ' Breite und Höhe der Internetseite speichern
                        lngSiteWidth = WebBrowser1.Document.body.scrollWidth + 4
                        lngSiteHeight = WebBrowser1.Document.body.scrollHeight + 4
                        
                    Else
                    
                        If WebBrowser1.Document.documentElement.clientWidth = _
                            WebBrowser1.Document.documentElement.scrollWidth And _
                            WebBrowser1.Document.documentElement.clientHeight = _
                            WebBrowser1.Document.documentElement.scrollHeight _
                            Then
                            
                            ' diese Seiten haben keine Scrollbalken, egal welche
                            ' Größe das Browserfenster hat
                            
                            ' Breite und Höhe auf die Mindestbreite und
                            ' Höhe festlegen
                            lngSiteWidth = minWidth + 4
                            lngSiteHeight = minHeight + 4
                            
                        Else
                        
                            ' diese Seiten haben Scrollbalken, egal welche
                            ' Größe das Browserfenster hat. Speziell die vertikale
                            ' ScrollBar ist, obwohl die Seite nicht mehr gescrollt
                            ' werden müsste, noch vorhanden.
                        
                            ' WebBrowser1.Document.body.Scroll = "no" funktioniert
                            ' bei diesen Seiten nicht um die Scrollbalken zu entfernen.
                            ' Daher rechnen wir die Breite und Höhe der Scrollbalken
                            ' zur eigentlichen Größe dazu. Für den Screenshot wird
                            ' dieser Offset später wieder abgezogen.
                            
                            ' Breite und Höhe der Internetseite + Breite
                            ' und Höhe der Scrollbalken
                            lngSiteWidth = _
                                WebBrowser1.Document.documentElement.scrollWidth _
                                + GetSystemMetrics(SM_CXVSCROLL) + 2
                                
                            lngSiteHeight = _
                                WebBrowser1.Document.documentElement.scrollHeight _
                                + GetSystemMetrics(SM_CYHSCROLL) + 2
                                
                            ' merken, das eventuell noch Scrollbalken vorhanden
                            ' sein können.
                            bolOffset = True
                            
                        End If
                    End If
                    
                    With tRECT
                    
                        ' automatisch ermittelte Höhe und Breite verwenden
                        If AutoSize Then
                        
                            .Right = lngSiteWidth
                            .Bottom = lngSiteHeight
                            
                        Else
                        
                            ' Mindesthöhe oder Breite verwenden es sei denn,
                            ' die Seite ist größer. Dann die ermittelte Höhe
                            ' oder Breite verwenden
                            If lngSiteWidth > minWidth Then
                            
                                .Right = lngSiteWidth
                                
                            End If
                            
                            If lngSiteHeight > minHeight Then
                            
                                .Bottom = lngSiteHeight
                                
                            End If
                        End If
                        
                    End With
                    
                    ' das Fenster "Shell DocObject View" auf die
                    ' ermittelte Größe aufziehen
                    If MoveWindow(lngDocViewHwnd, 0, 0, tRECT.Right, _
                        tRECT.Bottom, 0) <> 0 Then
                        
                        ' Inhalt der PicturBox löschen
                        picCapture.Cls
                        
                        ' die PictureBox auf die ermittelte Größe aufziehen
                        ' ist bolOffset = True dann müssen wir die Höhe
                        ' bzw. die Breite der Scrollbalken wieder abziehen
                        ' damit diese im ScreenShot nicht zu sehen sind
                        If MoveWindow(picCapture.hwnd, 0, 0, IIf(bolOffset, _
                            tRECT.Right - GetSystemMetrics(SM_CXVSCROLL), _
                            tRECT.Right), IIf(bolOffset, tRECT.Bottom - _
                            GetSystemMetrics(SM_CYHSCROLL), tRECT.Bottom), 0) <> _
                            0 Then
                            
                            ' OleDraw ruft per QueryInterface das
                            ' IViewObject-Interface auf
                            ' und indirekt davon die Funktion Draw. Diese
                            ' zeichnet dann den Inhalt von Document in ein DC.
                            If OleDraw(WebBrowser1.Document, DVASPECT_CONTENT, _
                                picCapture.hDC, tRECT) = S_OK Then
                                
                                ' Bild speichern
                                Call SavePicture(picCapture.Image, PicPath)
                                
                                ' Rückgabewert setzen
                                bolRet = True
                                
                            End If
                        End If
                        
                        ' Inhalt der PicturBox löschen
                        picCapture.Cls
                        
                    End If
                    
                    ' das Fenster "Shell DocObject View" auf die
                    ' ursprüngliche Größe zurücksetzen
                    Call MoveWindow(lngDocViewHwnd, 0, 0, lngOrgWidth, _
                        lngOrgHeight, 0)
                        
                    ' wurden die Scrollbalken durch
                    ' WebBrowser1.Document.body.Scroll = "no" entfernt
                    If bolScrollBars Then
                    
                        ' dann Scrollbalken wieder einschalten
                        WebBrowser1.Document.body.Scroll = "auto"
                        
                    End If
                End If
            End If
        End If
    End If
    
    ' Rückgabewert übergeben
    CaptureWeb = bolRet
    
End Function

Private Sub cmdCapture_Click()

    Dim strPath As String
    
    ' App.Path speichern
    strPath = App.Path
    
    ' \ anhängen falls nicht vorhanden
    If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    Me.Caption = "Bitte warten"
    
    ' wenn erfolgreich
    If CaptureWeb(strPath & "WebShot.bmp") Then
    
        MsgBox "Die Webseite wurde erfolgreich gespeichert."
        
    Else
    
        ' wenn nicht erfolgreich
        MsgBox "Die Webseite konnte nicht gespeichert werden."
        
    End If
    
    Me.Caption = App.Title & ": " & CStr(WebBrowser1.Document.URL)
    
End Sub

Private Sub cmdNavigate_Click()

    Dim strURL As String
    
    ' kein Text in der TextBox vorhanden
    If Len(txtURL.Text) = 0 Then
    
        ' leere Seite anzeigen
        strURL = "about:blank"
        
    Else
    
        ' Text speichern
        strURL = txtURL.Text
        
    End If
    
    ' Webseite aufrufen
    WebBrowser1.Navigate strURL
    
End Sub

Private Sub Form_Initialize()

     ' Diese Zeile schaltet die XP-Styles für Internetseiten ab
     ' Windows-XP ein. Zum testen kann man diese Zeile mal
     ' auskommentieren und auf www.google.de gehen. Die Buttons
     ' und die OptionButtons werden dann im Windows-Classic Design
     ' angezeigt anstatt im XP-Style.
     m_hMod = LoadLibrary("explorer.exe")
     
End Sub

Private Sub Form_Load()

    Me.Caption = App.Title

    picCapture.Visible = False
    picCapture.AutoRedraw = True
    
    txtURL.Text = "www.activevb.de"
    WebBrowser1.Navigate txtURL.Text
    
End Sub

Private Sub Form_Terminate()
    
    ' ist ein Handle auf ein Modul vorhanden
    If m_hMod <> 0 Then
        
        ' Modul wieder freigeben
        Call FreeLibrary(m_hMod)
        
    End If

End Sub

Private Sub txtURL_KeyPress(KeyAscii As Integer)

    ' wenn Enter gedrückt wurde
    If KeyAscii = 13 Then
    
        ' Beep verhindern
        KeyAscii = 0
        
        ' Code im Button aufrufen
        Call cmdNavigate_Click
        
    End If
    
End Sub

Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, _
    Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers _
    As Variant, Cancel As Boolean)
    
    ' solange wie die Seite noch geladen wird, den Button deaktivieren
    cmdCapture.Enabled = False
    
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)

    ' wenn die Seite fertig geladen wurde, den Button aktivieren
    cmdCapture.Enabled = True
    Me.Caption = App.Title & ": " & CStr(URL)
    
End Sub

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)

    ' unterbinden das ein neues Fenster geöffnet wird
    Cancel = True
    
End Sub


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