Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0785: Fenster oder Clientbereich von Fenstern kopieren

VB 5/6-Tipp 0785: Fenster oder Clientbereich von Fenstern kopieren

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, BringWindowToTop, GetClientRect, GetDC, GetWindowDC, GetWindowRect, ReleaseDC, SetActiveWindow, SetForegroundWindow

Download: Download des Beispielprojektes [7,52 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 Project1.vbp -------------
'------- Anfang Formular "frmCopy" alias frmCopy.frm  -------
' Steuerelement: Bildfeld-Steuerelement "Pic"
' Fensterinhalt incl. aller Controls kopieren, speichern
' oder drucken.
' frmCopy ist selbstkonsitent und kann wie eine Klasse
' eingesetzt werden.

' Autor/Copyright: K. Langbein, Activevb.de, 2007

Option Explicit

Private Declare Function GetDC Lib "user32" ( _
                ByVal hWnd As Long) As Long
                
Private Declare Function GetWindowDC Lib "user32" ( _
                         ByVal hWnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
                 ByVal hWnd As Long, _
                 ByVal hDC As Long) As Long

Private Declare Function BitBlt Lib "gdi32" ( _
                 ByVal hDCDest As Long, _
                 ByVal XDest As Long, _
                 ByVal YDest As Long, _
                 ByVal nWidth As Long, _
                 ByVal nHeight As Long, _
                 ByVal hDCSrc As Long, _
                 ByVal XSrc As Long, _
                 ByVal YSrc As Long, _
                 ByVal dwRop As Long) As Long
                 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
                         ByVal hWnd As Long, _
                         lpRect As Rect) As Long
                 
Private Declare Function GetClientRect Lib "user32" ( _
                         ByVal hWnd As Long, _
                         lpRect As Rect) As Long

Private Declare Function BringWindowToTop Lib "user32" ( _
                         ByVal hWnd As Long) As Long
                         
Private Declare Function SetActiveWindow Lib "user32.dll" ( _
                         ByVal hWnd As Long) As Long
                         
Private Declare Function SetForegroundWindow Lib "user32.dll" ( _
                         ByVal hWnd As Long) As Long

Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const SRCCOPY = &HCC0020
Public Function Clear()

    ' Inhalt wieder löschen
    Pic.Cls
    Pic.Move 10, 10, 10, 10

End Function

Public Sub CopyWindowToPic(ByVal hWnd As Long, ByVal ClientOnly As Boolean)
    
    On Error Goto err1
    
    Dim hSourceDc As Long ' Handles auf Quell- und Ziel-DC
    Dim hDestDC As Long
    Dim R As Rect
    Dim dx As Long
    Dim dy As Long
    Dim ret As Long
    
    If ClientOnly = False Then
        ret = GetWindowRect(hWnd, R)
        hSourceDc = GetWindowDC(hWnd)
    Else
        ret = GetClientRect(hWnd, R)
        hSourceDc = GetDC(hWnd)
    End If
    
    dx = R.Right - R.Left
    dy = R.Bottom - R.Top
    Pic.Width = dx
    Pic.Height = dy
    Pic.Cls
    
    hDestDC = Pic.hDC
    
    ret = BitBlt(hDestDC, 0, 0, dx, dy, hSourceDc, 0, 0, SRCCOPY)
exi:
    ret = ReleaseDC(hWnd, hSourceDc)
    Exit Sub
    
err1:

    Select Case Err

    Case 9999
        ' hier koennte irgendeine Fehlerbehandlung stehen
    Case Else

        MsgBox Err & ": " & Error$, 16
        Resume exi

    End Select

err2:

End Sub
Public Function SaveWindow(ByVal hWnd As Long, _
                           ByVal FileName As String, _
                           ByVal Activate As Boolean, _
                           ByVal ClientOnly As Boolean) As Long

    If Activate = True Then
        Call WindowToTop(hWnd)
    End If

    ' In die lokale Pictureboc kopieren
    Call CopyWindowToPic(hWnd, ClientOnly)
    
    ' Abspeichern
    SavePicture Pic.Image, FileName

End Function

Public Function CopyToClipboard(ByVal hWnd As Long, _
                                ByVal Activate As Boolean, _
                                ByVal ClientOnly As Boolean) As Long

    If Activate = True Then
        Call WindowToTop(hWnd)
    End If
    
    ' Die lokale Picturebox wird nur als Zwischenspeicher benötigt
    Call CopyWindowToPic(hWnd, ClientOnly)
    Clipboard.Clear
    Clipboard.SetData Pic.Image, 2
    
End Function

Public Function CopyWindow(ByVal hWnd As Long, _
                           ByVal Activate As Boolean, _
                           ByVal ClientOnly As Boolean) As Long

    If Activate = True Then
        Call WindowToTop(hWnd)
    End If
    
    ' Die lokale Picturebox wird als Speicher verwendet
    Call CopyWindowToPic(hWnd, ClientOnly)
    
End Function

Public Function WindowToTop(ByVal hWnd As Long) As Long

    BringWindowToTop hWnd
    SetForegroundWindow hWnd
    SetActiveWindow hWnd
    DoEvents
    
End Function


Private Sub Form_Load()

    Me.ScaleMode = 3    ' Damit die Größe der PB in Pixeln eingestellt
                        ' werden kann
    Pic.BorderStyle = 0 ' Damit Ränder nicht berücksichtgt werden müssen
    Pic.AutoRedraw = True
    Pic.ScaleMode = 3
    
End Sub

'-------- Ende Formular "frmCopy" alias frmCopy.frm  --------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Kontrollkästchen-Steuerelement "Check1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
Option Explicit
Private Sub Command1_Click()

    Dim Fn$
    Picture1.Cls
    Set Picture1 = Nothing
    Fn$ = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\") & "Window.bmp"
    
    Call frmCopy.SaveWindow(Form2.hWnd, Fn$, True, -1 * Check1.Value)
    Picture1.Picture = LoadPicture(Fn$)
    Unload frmCopy
    
End Sub


Private Sub Command2_Click()

    ' Ins Clipboard kopieren
    Call frmCopy.CopyToClipboard(Form2.hWnd, True, -1 * Check1.Value)
    
    ' In die lokale Picturebox übertragen (nur zur Kontrolle)
    Picture1.Picture = Clipboard.GetData
    Unload frmCopy
    
End Sub


Private Sub Command3_Click()

    ' Ein Ersatz für Printform, mit dem man jedoch auch
    ' fremde Fenster oder Controls aus dem eigenen Programm
    ' ausdrucken kann. Hier wird die Größe an des Papier
    ' angepasst. Man kann das Bild jedoch auch beliebig
    ' plazieren.

    Dim Aspect As Double
    Dim x As Double
    Dim y As Double
    Dim w As Double
    Dim h As Double
    
    ' Ins frmCopy.Pic kopieren
    Call frmCopy.CopyWindow(Form2.hWnd, True, -1 * Check1.Value)
    
    ' In der Picturebox anzeigen. Nur zur Kontrolle (wird nicht benötigt)
    Picture1.Picture = frmCopy.Pic.Image
    
    ' Drucker initialisieren
    Printer.Print " "
    
    ' Seitenverhältnis bestimmen
    Aspect = frmCopy.Pic.Width / frmCopy.Pic.Height
    
    ' Arbeiten mit mm. A4 ist 210 mm breit
    Printer.ScaleMode = 6
    
    ' Zielkoordinaten bestimmen
    x = 25
    y = 30
    w = Printer.ScaleWidth - 50
    h = w / Aspect
    
    ' Bild drucken
    Printer.PaintPicture frmCopy.Pic.Image, x, y, w, h
    Printer.EndDoc
    Unload frmCopy

End Sub


Private Sub Form_Load()
    Command1.Caption = "Save"
    Command2.Caption = "Copy"
    Command3.Caption = "Print"
    Form2.Show
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Figur-Steuerelement "Shape1" auf Frame1
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Figur-Steuerelement "Shape2"
' Steuerelement: Linien-Steuerelement "Line1"
'---------- Ende Formular "Form2" alias Form2.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------